usql/syntax.lisp

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