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-op) (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 (when (keywordp (caddr arglist)) (caddr arglist) nil)))
 118            (cond
 119              ((stringp (cadr arglist))
 120              (sql-expression :table (car arglist)
 121                              :alias (cadr arglist)
 122                              :type sqltype))
 123             ((keywordp (cadr arglist))
 124              (sql-expression :attribute (car arglist)
 125                              :type (cadr arglist)))
 126             (t
 127              (sql-expression :attribute (cadr arglist)
 128                              :table (car arglist)
 129                              :type sqltype)))))
 130         (t
 131          (error 'sql-user-error :message "bad expression syntax"))))
 132
 133
 134 ;; Exported functions for dealing with SQL syntax
 135
 136 (defun sql (&rest args)
 137   "Returns an SQL string generated from the SQL expressions
 138 ARGS. The expressions are translated into SQL strings and then
 139 concatenated with a single space delimiting each expression."
 140   (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
 141
 142 (defun sql-expression (&key string table alias attribute type)
 143   "Returns an SQL expression constructed from the supplied arguments
 144 which may be combined as follows: ATTRIBUTE and TYPE; ATTRIBUTE;
 145 ALIAS or TABLE and ATTRIBUTE and TYPE; ALIAS or TABLE and
 146 ATTRIBUTE; TABLE, ATTRIBUTE and TYPE; TABLE and ATTRIBUTE; TABLE
 147 and ALIAS; TABLE; and STRING."
 148   (cond
 149     (string
 150      (make-instance 'sql :string string))
 151     (attribute
 152      (make-instance 'sql-ident-attribute  :name attribute
 153                     :qualifier (or table alias)
 154                     :type type))
 155     ((and table (not attribute))
 156      (make-instance 'sql-ident-table :name table
 157                     :table-alias alias))))
 158
 159 (defun sql-operator (operation)
 160   "Returns the Lisp symbol corresponding to the SQL operation
 161   represented by the symbol OPERATION."
 162   (typecase operation
 163     (string nil)
 164     (symbol (gethash (symbol-name-default-case (symbol-name operation))
 165                      *sql-op-table*))))
 166
 167 (defun sql-operation (operation &rest rest)
 168   "Returns an SQL expression constructed from the supplied SQL
 169 operator or function OPERATION and its arguments REST. If
 170 OPERATION is passed the symbol FUNCTION then the first value in
 171 REST is taken to be a valid SQL function and the remaining values
 172 in REST its arguments."
 173   (if (sql-operator operation)
 174       (apply (symbol-function (sql-operator operation)) rest)
 175       (error "~A is not a recognized SQL operator." operation)))
 176
 177