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 ;;;; *************************************************************************
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 "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)))
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)))
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)
52 ;; Exported functions for enabling SQL syntax.
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)))
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)))
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)
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
79 '(eval-when (:compile-toplevel :load-toplevel :execute)
80 (if *restore-sql-reader-syntax*
81 (%enable-sql-reader-syntax)
82 (%disable-sql-reader-syntax))))
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))))
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))
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 #\))))
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))
112 ((stringp (cadr arglist))
113 (sql-expression :table (car arglist)
114 :alias (cadr arglist)
116 ((keywordp (cadr arglist))
117 (sql-expression :attribute (car arglist)
121 (sql-expression :attribute (cadr arglist)
126 (error 'clsql-sql-syntax-error :reason "bad expression syntax"))))
129 ;; Exported functions for dealing with SQL syntax
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)))
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
145 (make-instance 'sql :string string))
147 (make-instance 'sql-ident-attribute :name attribute
148 :qualifier (or table alias)
151 ((and table (not attribute))
152 (make-instance 'sql-ident-table :name table
153 :table-alias alias))))
155 (defun sql-operator (operation)
156 "Takes an SQL operator as an argument and returns the Lisp symbol
160 (symbol (gethash (symbol-name-default-case (symbol-name operation))
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)))