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