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