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 (unless *read-suppress
*
93 (cond ((string= (write-to-string (car sqllist
)) "||")
94 (cons (sql-operator 'concat-op
) (cdr sqllist
)))
95 ((and (= (length sqllist
) 1) (eql (car sqllist
) '*))
96 (apply #'generate-sql-reference sqllist
))
97 ((sql-operator (car sqllist
))
98 (cons (sql-operator (car sqllist
)) (cdr sqllist
)))
99 (t (apply #'generate-sql-reference sqllist
)))
101 (error 'sql-user-error
102 :message
(format nil
"Error ~A occured while attempting to parse '~A' at file position ~A"
103 (sql-user-error-message c
) sqllist
(file-position stream
))))))))
105 (defun disable-sql-close-syntax ()
106 "Internal function that disables the close syntax when leaving
108 (set-macro-character *sql-macro-close-char
* *original-reader-exit
*)
109 (setf *original-reader-exit
* nil
))
111 (defun enable-sql-close-syntax ()
112 "Internal function that enables close syntax when entering SQL
114 (setf *original-reader-exit
* (get-macro-character *sql-macro-close-char
*))
115 (set-macro-character *sql-macro-close-char
* (get-macro-character #\
))))
117 (defun generate-sql-reference (&rest arglist
)
118 (cond ((= (length arglist
) 1) ; string, table or attribute
119 (if (stringp (car arglist
))
120 (sql-expression :string
(car arglist
))
121 (sql-expression :attribute
(car arglist
))))
122 ((<= 2 (length arglist
))
123 (let ((sqltype (when (keywordp (caddr arglist
)) (caddr arglist
) nil
)))
125 ((stringp (cadr arglist
))
126 (sql-expression :table
(car arglist
)
127 :alias
(cadr arglist
)
129 ((keywordp (cadr arglist
))
130 (sql-expression :attribute
(car arglist
)
131 :type
(cadr arglist
)))
133 (sql-expression :attribute
(cadr arglist
)
137 (error 'sql-user-error
:message
"bad expression syntax"))))
140 ;; Exported functions for dealing with SQL syntax
142 (defun sql (&rest args
)
143 "Returns an SQL string generated from the expressions ARGS. The
144 expressions are translated into SQL strings and then concatenated
145 with a single space delimiting each expression. An error of type
146 SQL-USER-ERROR is signalled if any element in ARGS is not of the
147 supported types (a symbol, string, number or symbolic SQL
148 expression) or a list or vector containing only these supported
150 (format nil
"~{~A~^ ~}" (mapcar #'sql-output args
)))
152 (defun sql-expression (&key string table alias attribute type
)
153 "Returns an SQL expression constructed from the supplied
154 arguments which may be combined as follows: ATTRIBUTE and TYPE;
155 ATTRIBUTE; ALIAS or TABLE and ATTRIBUTE and TYPE; ALIAS or TABLE
156 and ATTRIBUTE; TABLE, ATTRIBUTE and TYPE; TABLE and ATTRIBUTE;
157 TABLE and ALIAS; TABLE; and STRING. An error of type
158 SQL-USER-ERROR is signalled if an unsupported combination of
159 keyword arguments is specified."
162 (make-instance 'sql
:string string
))
164 (make-instance 'sql-ident-attribute
:name attribute
165 :qualifier
(or table alias
)
167 ((and table
(not attribute
))
168 (make-instance 'sql-ident-table
:name table
169 :table-alias alias
))))
171 (defun sql-operator (operator)
172 "Returns the Lisp symbol corresponding to the SQL operator
173 represented by the symbol OPERATOR. If OPERATOR does not
174 represent a supported SQL operator or is not a symbol, nil is
178 (symbol (values (gethash (symbol-name-default-case (symbol-name operator
))
181 (defun sql-operation (operator &rest args
)
182 "Returns an SQL expression constructed from the supplied symbol
183 OPERATOR representing an SQL operator or function and its
184 arguments ARGS. An error of type SQL-USER-ERROR is signalled if
185 OPERATOR is not a symbol representing a supported SQL
186 operator. If OPERATOR is passed the symbol FUNCTION then the
187 first value in ARGS must be a string representing a valid SQL
188 function and the remaining values in ARGS its arguments as
190 (if (sql-operator operator
)
191 (apply (symbol-function (sql-operator operator
)) args
)
192 (error 'sql-user-error
194 (format nil
"~A is not a recognized SQL operator." operator
))))