sql/syntax.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;;
   4 ;;;; $Id$
   5 ;;;;
   6 ;;;; CLSQL square bracket symbolic query syntax. Functions for
   7 ;;;; enabling and disabling the syntax and for building SQL
   8 ;;;; expressions using the syntax.
   9 ;;;;
  10 ;;;; This file is part of CLSQL.
  11 ;;;;
  12 ;;;; CLSQL users are granted the rights to distribute and use this software
  13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  15 ;;;; *************************************************************************
  16
  17
  18 (in-package #:clsql-sys)
  19
  20 (defvar *original-reader-enter* nil)
  21
  22 (defvar *original-reader-exit* nil)
  23
  24 (defvar *sql-macro-open-char* #\[)
  25
  26 (defvar *sql-macro-close-char* #\])
  27
  28 (defvar *restore-sql-reader-syntax* nil)
  29
  30
  31 ;; Exported functions for disabling SQL syntax.
  32
  33 (defmacro disable-sql-reader-syntax ()
  34   "Turn off SQL square bracket syntax changing syntax state. Set state
  35 such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax
  36 disabled if it is consequently locally enabled."
  37   '(eval-when (:compile-toplevel :load-toplevel :execute)
  38      (setf *restore-sql-reader-syntax* nil)
  39      (%disable-sql-reader-syntax)))
  40
  41 (defmacro locally-disable-sql-reader-syntax ()
  42   "Turn off SQL square bracket syntax and do not change syntax state."
  43   '(eval-when (:compile-toplevel :load-toplevel :execute)
  44     (%disable-sql-reader-syntax)))
  45
  46 (defun %disable-sql-reader-syntax ()
  47   (when *original-reader-enter*
  48     (set-macro-character *sql-macro-open-char* *original-reader-enter*))
  49   (setf *original-reader-enter* nil)
  50   (values))
  51
  52
  53 ;; Exported functions for enabling SQL syntax.
  54
  55 (defmacro enable-sql-reader-syntax ()
  56   "Turn on SQL square bracket syntax changing syntax state. Set state
  57 such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax enabled
  58 if it is consequently locally disabled."
  59   '(eval-when (:compile-toplevel :load-toplevel :execute)
  60      (setf *restore-sql-reader-syntax* t)
  61      (%enable-sql-reader-syntax)))
  62
  63 (defmacro locally-enable-sql-reader-syntax ()
  64   "Turn on SQL square bracket syntax and do not change syntax state."
  65   '(eval-when (:compile-toplevel :load-toplevel :execute)
  66      (%enable-sql-reader-syntax)))
  67
  68 (defun %enable-sql-reader-syntax ()
  69   (unless *original-reader-enter*
  70     (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*)))
  71   (set-macro-character *sql-macro-open-char* #'sql-reader-open)
  72   (enable-sql-close-syntax)
  73   (values))
  74
  75 (defmacro restore-sql-reader-syntax-state ()
  76   "Sets the enable/disable square bracket syntax state to reflect the
  77 last call to either DISABLE-SQL-READER-SYNTAX or
  78 ENABLE-SQL-READER-SYNTAX. The default state of the square bracket
  79 syntax is disabled."
  80   '(eval-when (:compile-toplevel :load-toplevel :execute)
  81     (if *restore-sql-reader-syntax*
  82         (%enable-sql-reader-syntax)
  83         (%disable-sql-reader-syntax))))
  84
  85 (defun sql-reader-open (stream char)
  86   (declare (ignore char))
  87   (let ((sqllist (read-delimited-list #\] stream t)))
  88     (if (sql-operator (car sqllist))
  89         (cons (sql-operator (car sqllist)) (cdr sqllist))
  90       (apply #'generate-sql-reference sqllist))))
  91
  92 ;; Internal function that disables the close syntax when leaving sql context.
  93 (defun disable-sql-close-syntax ()
  94   (set-macro-character *sql-macro-close-char* *original-reader-exit*)
  95   (setf *original-reader-exit* nil))
  96
  97 ;; Internal function that enables close syntax when entering SQL context.
  98 (defun enable-sql-close-syntax ()
  99   (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
 100   (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
 101
 102 (defun generate-sql-reference (&rest arglist)
 103   (cond ((= (length arglist) 1) ; string, table or attribute
 104          (if (stringp (car arglist))
 105              (sql-expression :string (car arglist))
 106            (sql-expression :attribute (car arglist))))
 107         ((<= 2 (length arglist))
 108          (let ((sqltype (if (keywordp (caddr arglist))
 109                             (caddr arglist) nil))
 110                (sqlparam (if (keywordp (caddr arglist))
 111                              (caddr arglist))))
 112            (cond
 113             ((stringp (cadr arglist))
 114              (sql-expression :table (car arglist)
 115                              :alias (cadr arglist)
 116                              :type sqltype))
 117             ((keywordp (cadr arglist))
 118              (sql-expression :attribute (car arglist)
 119                              :type (cadr arglist)
 120                              :params sqlparam))
 121             (t
 122              (sql-expression :attribute (cadr arglist)
 123                              :table (car arglist)
 124                              :params sqlparam
 125                              :type sqltype)))))
 126         (t
 127          (error 'clsql-sql-syntax-error :reason "bad expression syntax"))))
 128
 129
 130 ;; Exported functions for dealing with SQL syntax
 131
 132 (defun sql (&rest args)
 133   "Generates SQL from a set of expressions given by ARGS. Each
 134 argument is translated into SQL and then the args are concatenated
 135 with a single space between each pair."
 136   (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
 137
 138 (defun sql-expression (&key string table alias attribute type params)
 139   "Generates an SQL expression from the given keywords. Valid
 140 combinations of the arguments are: string; table; table and alias;
 141 table and attribute; table, attribute, and type; table or alias, and
 142 attribute; table or alias, and attribute and type; attribute; and
 143 attribute and type."
 144   (cond
 145     (string
 146      (make-instance 'sql :string string))
 147     (attribute
 148      (make-instance 'sql-ident-attribute  :name attribute
 149                     :qualifier (or table alias)
 150                     :type type
 151                     :params params))
 152     ((and table (not attribute))
 153      (make-instance 'sql-ident-table :name table
 154                     :table-alias alias))))
 155
 156 (defun sql-operator (operation)
 157   "Takes an SQL operator as an argument and returns the Lisp symbol
 158 for the operator."
 159   (typecase operation
 160     (string nil)
 161     (symbol (gethash (symbol-name-default-case (symbol-name operation))
 162                      *sql-op-table*))))
 163
 164 (defun sql-operation (operation &rest rest)
 165   "Generates an SQL statement from an operator and arguments."
 166   (if (sql-operator operation)
 167       (apply (symbol-function (sql-operator operation)) rest)
 168       (error "~A is not a recognized SQL operator." operation)))
 169
 170