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 (when *original-reader-exit*
51 (set-macro-character *sql-macro-close-char* *original-reader-exit*))
55 ;; Exported functions for enabling SQL syntax.
57 (defmacro enable-sql-reader-syntax ()
58 "Turns on the SQL reader syntax setting the syntax state such
59 that if the syntax is subsequently disabled,
60 RESTORE-SQL-READER-SYNTAX-STATE will enable it again."
61 '(eval-when (:compile-toplevel :load-toplevel :execute)
62 (setf *restore-sql-reader-syntax* t)
63 (%enable-sql-reader-syntax)))
65 (defmacro locally-enable-sql-reader-syntax ()
66 "Turns on the SQL reader syntax without changing the syntax
67 state such that RESTORE-SQL-READER-SYNTAX-STATE will re-establish
68 the current syntax state."
69 '(eval-when (:compile-toplevel :load-toplevel :execute)
70 (%enable-sql-reader-syntax)))
72 (defun %enable-sql-reader-syntax ()
73 (unless (eq (get-macro-character *sql-macro-open-char*) #'sql-reader-open)
74 (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*))
75 (set-macro-character *sql-macro-open-char* #'sql-reader-open))
76 (unless (eq (get-macro-character *sql-macro-close-char*)
77 (get-macro-character #\)))
78 (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
79 (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
82 (defmacro restore-sql-reader-syntax-state ()
83 "Enables the SQL reader syntax if ENABLE-SQL-READER-SYNTAX has
84 been called more recently than DISABLE-SQL-READER-SYNTAX and
85 otherwise disables the SQL reader syntax. By default, the SQL
86 reader syntax is disabled."
87 '(eval-when (:compile-toplevel :load-toplevel :execute)
88 (if *restore-sql-reader-syntax*
89 (%enable-sql-reader-syntax)
90 (%disable-sql-reader-syntax))))
92 (defun sql-reader-open (stream char)
93 (declare (ignore char))
94 (let ((sqllist (read-delimited-list #\] stream t)))
95 (unless *read-suppress*
97 (cond ((string= (write-to-string (car sqllist)) "||")
98 (cons (sql-operator 'concat-op) (cdr sqllist)))
99 ((and (= (length sqllist) 1) (eql (car sqllist) '*))
100 (apply #'generate-sql-reference sqllist))
101 ((sql-operator (car sqllist))
102 (cons (sql-operator (car sqllist)) (cdr sqllist)))
103 (t (apply #'generate-sql-reference sqllist)))
105 (error 'sql-user-error
106 :message (format nil "Error ~A occured while attempting to parse '~A' at file position ~A"
107 (sql-user-error-message c) sqllist (file-position stream))))))))
109 (defun generate-sql-reference (&rest arglist)
110 (cond ((= (length arglist) 1) ; string, table or attribute
111 (if (stringp (car arglist))
112 (sql-expression :string (car arglist))
113 (sql-expression :attribute (car arglist))))
114 ((<= 2 (length arglist))
115 (let ((sqltype (when (keywordp (caddr arglist)) (caddr arglist) nil)))
117 ((stringp (cadr arglist))
118 (sql-expression :table (car arglist)
119 :alias (cadr arglist)
121 ((keywordp (cadr arglist))
122 (sql-expression :attribute (car arglist)
123 :type (cadr arglist)))
125 (sql-expression :attribute (cadr arglist)
129 (error 'sql-user-error :message "bad expression syntax"))))
132 ;; Exported functions for dealing with SQL syntax
134 (defun sql (&rest args)
135 "Returns an SQL string generated from the expressions ARGS. The
136 expressions are translated into SQL strings and then concatenated
137 with a single space delimiting each expression. An error of type
138 SQL-USER-ERROR is signalled if any element in ARGS is not of the
139 supported types (a symbol, string, number or symbolic SQL
140 expression) or a list or vector containing only these supported
142 (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
144 (defun sql-expression (&key string table alias attribute type)
145 "Returns an SQL expression constructed from the supplied
146 arguments which may be combined as follows: ATTRIBUTE and TYPE;
147 ATTRIBUTE; ALIAS or TABLE and ATTRIBUTE and TYPE; ALIAS or TABLE
148 and ATTRIBUTE; TABLE, ATTRIBUTE and TYPE; TABLE and ATTRIBUTE;
149 TABLE and ALIAS; TABLE; and STRING. An error of type
150 SQL-USER-ERROR is signalled if an unsupported combination of
151 keyword arguments is specified."
154 (make-instance 'sql :string string))
156 (make-instance 'sql-ident-attribute :name attribute
157 :qualifier (or table alias)
159 ((and table (not attribute))
160 (make-instance 'sql-ident-table :name table
161 :table-alias alias))))
163 (defun sql-operator (operator)
164 "Returns the Lisp symbol corresponding to the SQL operator
165 represented by the symbol OPERATOR. If OPERATOR does not
166 represent a supported SQL operator or is not a symbol, nil is
170 (symbol (values (gethash (symbol-name-default-case (symbol-name operator))
173 (defun sql-operation (operator &rest args)
174 "Returns an SQL expression constructed from the supplied symbol
175 OPERATOR representing an SQL operator or function and its
176 arguments ARGS. An error of type SQL-USER-ERROR is signalled if
177 OPERATOR is not a symbol representing a supported SQL
178 operator. If OPERATOR is passed the symbol FUNCTION then the
179 first value in ARGS must be a string representing a valid SQL
180 function and the remaining values in ARGS its arguments as
182 (if (sql-operator operator)
183 (apply (symbol-function (sql-operator operator)) args)
184 (error 'sql-user-error
186 (format nil "~A is not a recognized SQL operator." operator))))