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   "Turn off SQL square bracket syntax changing syntax state. Set state
  34 such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax
  35 disabled if it is consequently locally enabled."
  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   "Turn off SQL square bracket syntax and do not change syntax state."
  42   '(eval-when (:compile-toplevel :load-toplevel :execute)
  43     (%disable-sql-reader-syntax)))
  44
  45 (defun %disable-sql-reader-syntax ()
  46   (when *original-reader-enter*
  47     (set-macro-character *sql-macro-open-char* *original-reader-enter*))
  48   (setf *original-reader-enter* nil)
  49   (values))
  50
  51
  52 ;; Exported functions for enabling SQL syntax.
  53
  54 (defmacro enable-sql-reader-syntax ()
  55   "Turn on SQL square bracket syntax changing syntax state. Set state
  56 such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax enabled
  57 if it is consequently locally disabled."
  58   '(eval-when (:compile-toplevel :load-toplevel :execute)
  59      (setf *restore-sql-reader-syntax* t)
  60      (%enable-sql-reader-syntax)))
  61
  62 (defmacro locally-enable-sql-reader-syntax ()
  63   "Turn on SQL square bracket syntax and do not change syntax state."
  64   '(eval-when (:compile-toplevel :load-toplevel :execute)
  65      (%enable-sql-reader-syntax)))
  66
  67 (defun %enable-sql-reader-syntax ()
  68   (unless *original-reader-enter*
  69     (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*)))
  70   (set-macro-character *sql-macro-open-char* #'sql-reader-open)
  71   (enable-sql-close-syntax)
  72   (values))
  73
  74 (defmacro restore-sql-reader-syntax-state ()
  75   "Sets the enable/disable square bracket syntax state to reflect the
  76 last call to either DISABLE-SQL-READER-SYNTAX or
  77 ENABLE-SQL-READER-SYNTAX. The default state of the square bracket
  78 syntax is disabled."
  79   '(eval-when (:compile-toplevel :load-toplevel :execute)
  80     (if *restore-sql-reader-syntax*
  81         (%enable-sql-reader-syntax)
  82         (%disable-sql-reader-syntax))))
  83
  84 (defun sql-reader-open (stream char)
  85   (declare (ignore char))
  86   (let ((sqllist (read-delimited-list #\] stream t)))
  87     (cond ((string= (write-to-string (car sqllist)) "||")
  88            (cons (sql-operator 'concat) (cdr sqllist)))
  89           ((and (= (length sqllist) 1) (eql (car sqllist) '*))
  90            (apply #'generate-sql-reference sqllist))
  91           ((sql-operator (car sqllist))
  92            (cons (sql-operator (car sqllist)) (cdr sqllist)))
  93           (t (apply #'generate-sql-reference sqllist)))))
  94
  95 ;; Internal function that disables the close syntax when leaving sql context.
  96 (defun disable-sql-close-syntax ()
  97   (set-macro-character *sql-macro-close-char* *original-reader-exit*)
  98   (setf *original-reader-exit* nil))
  99
 100 ;; Internal function that enables close syntax when entering SQL context.
 101 (defun enable-sql-close-syntax ()
 102   (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
 103   (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
 104
 105 (defun generate-sql-reference (&rest arglist)
 106   (cond ((= (length arglist) 1) ; string, table or attribute
 107          (if (stringp (car arglist))
 108              (sql-expression :string (car arglist))
 109            (sql-expression :attribute (car arglist))))
 110         ((<= 2 (length arglist))
 111          (let ((sqltype (if (keywordp (caddr arglist))
 112                             (caddr arglist) nil))
 113                (sqlparam (if (keywordp (caddr arglist))
 114                              (caddr arglist))))
 115            (cond
 116             ((stringp (cadr arglist))
 117              (sql-expression :table (car arglist)
 118                              :alias (cadr arglist)
 119                              :type sqltype))
 120             ((keywordp (cadr arglist))
 121              (sql-expression :attribute (car arglist)
 122                              :type (cadr arglist)
 123                              :params sqlparam))
 124             (t
 125              (sql-expression :attribute (cadr arglist)
 126                              :table (car arglist)
 127                              :params sqlparam
 128                              :type sqltype)))))
 129         (t
 130          (error 'clsql-sql-syntax-error :reason "bad expression syntax"))))
 131
 132
 133 ;; Exported functions for dealing with SQL syntax
 134
 135 (defun sql (&rest args)
 136   "Generates SQL from a set of expressions given by ARGS. Each
 137 argument is translated into SQL and then the args are concatenated
 138 with a single space between each pair."
 139   (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
 140
 141 (defun sql-expression (&key string table alias attribute type params)
 142   "Generates an SQL expression from the given keywords. Valid
 143 combinations of the arguments are: string; table; table and alias;
 144 table and attribute; table, attribute, and type; table or alias, and
 145 attribute; table or alias, and attribute and type; attribute; and
 146 attribute and type."
 147   (cond
 148     (string
 149      (make-instance 'sql :string string))
 150     (attribute
 151      (make-instance 'sql-ident-attribute  :name attribute
 152                     :qualifier (or table alias)
 153                     :type type
 154                     :params params))
 155     ((and table (not attribute))
 156      (make-instance 'sql-ident-table :name table
 157                     :table-alias alias))))
 158
 159 (defun sql-operator (operation)
 160   "Takes an SQL operator as an argument and returns the Lisp symbol
 161 for the operator."
 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   "Generates an SQL statement from an operator and arguments."
 169   (if (sql-operator operation)
 170       (apply (symbol-function (sql-operator operation)) rest)
 171       (error "~A is not a recognized SQL operator." operation)))
 172
 173