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 (in-package #:clsql-sys)
  18
  19 (defvar *original-reader-enter* nil)
  20
  21 (defvar *original-reader-exit* nil)
  22
  23 (defvar *sql-macro-open-char* #\[)
  24
  25 (defvar *sql-macro-close-char* #\])
  26
  27 (defvar *restore-sql-reader-syntax* nil)
  28
  29
  30 ;; Exported functions for disabling SQL syntax.
  31
  32 (defmacro disable-sql-reader-syntax ()
  33   "Turns off the SQL reader syntax setting the syntax state such
  34 that if the syntax is subsequently enabled,
  35 RESTORE-SQL-READER-SYNTAX-STATE will disable it again."
  36   '(eval-when (:compile-toplevel :load-toplevel :execute)
  37     (setf *restore-sql-reader-syntax* nil)
  38     (%disable-sql-reader-syntax)))
  39
  40 (defmacro locally-disable-sql-reader-syntax ()
  41   "Turns off the SQL reader syntax without changing the syntax
  42 state such that RESTORE-SQL-READER-SYNTAX-STATE will re-establish
  43 the current syntax state."
  44   '(eval-when (:compile-toplevel :load-toplevel :execute)
  45     (%disable-sql-reader-syntax)))
  46
  47 (defun %disable-sql-reader-syntax ()
  48   (when *original-reader-enter*
  49     (set-macro-character *sql-macro-open-char* *original-reader-enter*))
  50   (setf *original-reader-enter* nil)
  51   (values))
  52
  53
  54 ;; Exported functions for enabling SQL syntax.
  55
  56 (defmacro enable-sql-reader-syntax ()
  57   "Turns on the SQL reader syntax setting the syntax state such
  58 that if the syntax is subsequently disabled,
  59 RESTORE-SQL-READER-SYNTAX-STATE will enable it again."
  60   '(eval-when (:compile-toplevel :load-toplevel :execute)
  61     (setf *restore-sql-reader-syntax* t)
  62     (%enable-sql-reader-syntax)))
  63
  64 (defmacro locally-enable-sql-reader-syntax ()
  65   "Turns on the SQL reader syntax without changing the syntax
  66 state such that RESTORE-SQL-READER-SYNTAX-STATE will re-establish
  67 the current syntax state."
  68   '(eval-when (:compile-toplevel :load-toplevel :execute)
  69     (%enable-sql-reader-syntax)))
  70
  71 (defun %enable-sql-reader-syntax ()
  72   (unless *original-reader-enter*
  73     (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*)))
  74   (set-macro-character *sql-macro-open-char* #'sql-reader-open)
  75   (enable-sql-close-syntax)
  76   (values))
  77
  78 (defmacro restore-sql-reader-syntax-state ()
  79   "Enables the SQL reader syntax if ENABLE-SQL-READER-SYNTAX has
  80 been called more recently than DISABLE-SQL-READER-SYNTAX and
  81 otherwise disables the SQL reader syntax. By default, the SQL
  82 reader syntax is disabled."
  83   '(eval-when (:compile-toplevel :load-toplevel :execute)
  84     (if *restore-sql-reader-syntax*
  85         (%enable-sql-reader-syntax)
  86         (%disable-sql-reader-syntax))))
  87
  88 (defun sql-reader-open (stream char)
  89   (declare (ignore char))
  90   (let ((sqllist (read-delimited-list #\] stream t)))
  91     (cond ((string= (write-to-string (car sqllist)) "||")
  92            (cons (sql-operator 'concat) (cdr sqllist)))
  93           ((and (= (length sqllist) 1) (eql (car sqllist) '*))
  94            (apply #'generate-sql-reference sqllist))
  95           ((sql-operator (car sqllist))
  96            (cons (sql-operator (car sqllist)) (cdr sqllist)))
  97           (t (apply #'generate-sql-reference sqllist)))))
  98
  99 (defun disable-sql-close-syntax ()
 100   "Internal function that disables the close syntax when leaving
 101   sql context."
 102   (set-macro-character *sql-macro-close-char* *original-reader-exit*)
 103   (setf *original-reader-exit* nil))
 104
 105 (defun enable-sql-close-syntax ()
 106   "Internal function that enables close syntax when entering SQL
 107   context."
 108   (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
 109   (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
 110
 111 (defun generate-sql-reference (&rest arglist)
 112   (cond ((= (length arglist) 1) ; string, table or attribute
 113          (if (stringp (car arglist))
 114              (sql-expression :string (car arglist))
 115              (sql-expression :attribute (car arglist))))
 116         ((<= 2 (length arglist))
 117          (let ((sqltype (if (keywordp (caddr arglist))
 118                             (caddr arglist) nil))
 119                (sqlparam (if (keywordp (caddr arglist))
 120                              (caddr arglist))))
 121            (cond
 122              ((stringp (cadr arglist))
 123              (sql-expression :table (car arglist)
 124                              :alias (cadr arglist)
 125                              :type sqltype))
 126             ((keywordp (cadr arglist))
 127              (sql-expression :attribute (car arglist)
 128                              :type (cadr arglist)
 129                              :params sqlparam))
 130             (t
 131              (sql-expression :attribute (cadr arglist)
 132                              :table (car arglist)
 133                              :params sqlparam
 134                              :type sqltype)))))
 135         (t
 136          (error 'clsql-sql-syntax-error :reason "bad expression syntax"))))
 137
 138
 139 ;; Exported functions for dealing with SQL syntax
 140
 141 (defun sql (&rest args)
 142   "Returns an SQL string generated from the SQL expressions
 143 ARGS. The expressions are translated into SQL strings and then
 144 concatenated with a single space delimiting each expression."
 145   (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
 146
 147 (defun sql-expression (&key string table alias attribute type params)
 148   "Returns an SQL expression constructed from the supplied arguments
 149 which may be combined as follows: ATTRIBUTE and TYPE; ATTRIBUTE;
 150 ALIAS or TABLE and ATTRIBUTE and TYPE; ALIAS or TABLE and
 151 ATTRIBUTE; TABLE, ATTRIBUTE and TYPE; TABLE and ATTRIBUTE; TABLE
 152 and ALIAS; TABLE; and STRING."
 153   (cond
 154     (string
 155      (make-instance 'sql :string string))
 156     (attribute
 157      (make-instance 'sql-ident-attribute  :name attribute
 158                     :qualifier (or table alias)
 159                     :type type
 160                     :params params))
 161     ((and table (not attribute))
 162      (make-instance 'sql-ident-table :name table
 163                     :table-alias alias))))
 164
 165 (defun sql-operator (operation)
 166   "Returns the Lisp symbol corresponding to the SQL operation
 167   represented by the symbol OPERATION."
 168   (typecase operation
 169     (string nil)
 170     (symbol (gethash (symbol-name-default-case (symbol-name operation))
 171                      *sql-op-table*))))
 172
 173 (defun sql-operation (operation &rest rest)
 174   "Returns an SQL expression constructed from the supplied SQL
 175 operator or function OPERATION and its arguments REST. If
 176 OPERATION is passed the symbol FUNCTION then the first value in
 177 REST is taken to be a valid SQL function and the remaining values
 178 in REST its arguments."
 179   (if (sql-operator operation)
 180       (apply (symbol-function (sql-operator operation)) rest)
 181       (error "~A is not a recognized SQL operator." operation)))
 182
 183