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           ((sql-operator (car sqllist))
  90            (cons (sql-operator (car sqllist)) (cdr sqllist)))
  91           (t (apply #'generate-sql-reference sqllist)))))
  92
  93 ;; Internal function that disables the close syntax when leaving sql context.
  94 (defun disable-sql-close-syntax ()
  95   (set-macro-character *sql-macro-close-char* *original-reader-exit*)
  96   (setf *original-reader-exit* nil))
  97
  98 ;; Internal function that enables close syntax when entering SQL context.
  99 (defun enable-sql-close-syntax ()
 100   (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
 101   (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
 102
 103 (defun generate-sql-reference (&rest arglist)
 104   (cond ((= (length arglist) 1) ; string, table or attribute
 105          (if (stringp (car arglist))
 106              (sql-expression :string (car arglist))
 107            (sql-expression :attribute (car arglist))))
 108         ((<= 2 (length arglist))
 109          (let ((sqltype (if (keywordp (caddr arglist))
 110                             (caddr arglist) nil))
 111                (sqlparam (if (keywordp (caddr arglist))
 112                              (caddr arglist))))
 113            (cond
 114             ((stringp (cadr arglist))
 115              (sql-expression :table (car arglist)
 116                              :alias (cadr arglist)
 117                              :type sqltype))
 118             ((keywordp (cadr arglist))
 119              (sql-expression :attribute (car arglist)
 120                              :type (cadr arglist)
 121                              :params sqlparam))
 122             (t
 123              (sql-expression :attribute (cadr arglist)
 124                              :table (car arglist)
 125                              :params sqlparam
 126                              :type sqltype)))))
 127         (t
 128          (error 'clsql-sql-syntax-error :reason "bad expression syntax"))))
 129
 130
 131 ;; Exported functions for dealing with SQL syntax
 132
 133 (defun sql (&rest args)
 134   "Generates SQL from a set of expressions given by ARGS. Each
 135 argument is translated into SQL and then the args are concatenated
 136 with a single space between each pair."
 137   (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
 138
 139 (defun sql-expression (&key string table alias attribute type params)
 140   "Generates an SQL expression from the given keywords. Valid
 141 combinations of the arguments are: string; table; table and alias;
 142 table and attribute; table, attribute, and type; table or alias, and
 143 attribute; table or alias, and attribute and type; attribute; and
 144 attribute and type."
 145   (cond
 146     (string
 147      (make-instance 'sql :string string))
 148     (attribute
 149      (make-instance 'sql-ident-attribute  :name attribute
 150                     :qualifier (or table alias)
 151                     :type type
 152                     :params params))
 153     ((and table (not attribute))
 154      (make-instance 'sql-ident-table :name table
 155                     :table-alias alias))))
 156
 157 (defun sql-operator (operation)
 158   "Takes an SQL operator as an argument and returns the Lisp symbol
 159 for the operator."
 160   (typecase operation
 161     (string nil)
 162     (symbol (gethash (symbol-name-default-case (symbol-name operation))
 163                      *sql-op-table*))))
 164
 165 (defun sql-operation (operation &rest rest)
 166   "Generates an SQL statement from an operator and arguments."
 167   (if (sql-operator operation)
 168       (apply (symbol-function (sql-operator operation)) rest)
 169       (error "~A is not a recognized SQL operator." operation)))
 170
 171