1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; CLSQL square bracket symbolic query syntax. Functions for
7 ;;;; enabling and disabling the syntax and for building SQL
8 ;;;; expressions using the syntax.
10 ;;;; This file is part of CLSQL.
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 ;;;; *************************************************************************
17 (in-package #:clsql-sys)
19 (defvar *original-reader-enter* nil)
21 (defvar *original-reader-exit* nil)
23 (defvar *sql-macro-open-char* #\[)
25 (defvar *sql-macro-close-char* #\])
27 (defvar *restore-sql-reader-syntax* nil)
30 ;; Exported functions for disabling SQL syntax.
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)))
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)))
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)
54 ;; Exported functions for enabling SQL syntax.
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)))
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)))
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)
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))))
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)))))
99 (defun disable-sql-close-syntax ()
100 "Internal function that disables the close syntax when leaving
102 (set-macro-character *sql-macro-close-char* *original-reader-exit*)
103 (setf *original-reader-exit* nil))
105 (defun enable-sql-close-syntax ()
106 "Internal function that enables close syntax when entering SQL
108 (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
109 (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
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)))
119 ((stringp (cadr arglist))
120 (sql-expression :table (car arglist)
121 :alias (cadr arglist)
123 ((keywordp (cadr arglist))
124 (sql-expression :attribute (car arglist)
125 :type (cadr arglist)))
127 (sql-expression :attribute (cadr arglist)
131 (error 'sql-user-error :message "bad expression syntax"))))
134 ;; Exported functions for dealing with SQL syntax
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)))
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."
150 (make-instance 'sql :string string))
152 (make-instance 'sql-ident-attribute :name attribute
153 :qualifier (or table alias)
155 ((and table (not attribute))
156 (make-instance 'sql-ident-table :name table
157 :table-alias alias))))
159 (defun sql-operator (operation)
160 "Returns the Lisp symbol corresponding to the SQL operation
161 represented by the symbol OPERATION."
164 (symbol (values (gethash (symbol-name-default-case (symbol-name operation))
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 'sql-user-error
177 (format nil "~A is not a recognized SQL operator." operation))))