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 ;;;; *************************************************************************
18 (in-package #:clsql-sys)
20 (defvar *original-reader-enter* nil)
22 (defvar *original-reader-exit* nil)
24 (defvar *sql-macro-open-char* #\[)
26 (defvar *sql-macro-close-char* #\])
28 (defvar *restore-sql-reader-syntax* nil)
31 ;; Exported functions for disabling SQL syntax.
33 (defmacro disable-sql-reader-syntax ()
34 "Turn off SQL square bracket syntax changing syntax state. Set state
35 such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax
36 disabled if it is consequently locally enabled."
37 '(eval-when (:compile-toplevel :load-toplevel :execute)
38 (setf *restore-sql-reader-syntax* nil)
39 (%disable-sql-reader-syntax)))
41 (defmacro locally-disable-sql-reader-syntax ()
42 "Turn off SQL square bracket syntax and do not change syntax state."
43 '(eval-when (:compile-toplevel :load-toplevel :execute)
44 (%disable-sql-reader-syntax)))
46 (defun %disable-sql-reader-syntax ()
47 (when *original-reader-enter*
48 (set-macro-character *sql-macro-open-char* *original-reader-enter*))
49 (setf *original-reader-enter* nil)
53 ;; Exported functions for enabling SQL syntax.
55 (defmacro enable-sql-reader-syntax ()
56 "Turn on SQL square bracket syntax changing syntax state. Set state
57 such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax enabled
58 if it is consequently locally disabled."
59 '(eval-when (:compile-toplevel :load-toplevel :execute)
60 (setf *restore-sql-reader-syntax* t)
61 (%enable-sql-reader-syntax)))
63 (defmacro locally-enable-sql-reader-syntax ()
64 "Turn on SQL square bracket syntax and do not change syntax state."
65 '(eval-when (:compile-toplevel :load-toplevel :execute)
66 (%enable-sql-reader-syntax)))
68 (defun %enable-sql-reader-syntax ()
69 (unless *original-reader-enter*
70 (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*)))
71 (set-macro-character *sql-macro-open-char* #'sql-reader-open)
72 (enable-sql-close-syntax)
75 (defmacro restore-sql-reader-syntax-state ()
76 "Sets the enable/disable square bracket syntax state to reflect the
77 last call to either DISABLE-SQL-READER-SYNTAX or
78 ENABLE-SQL-READER-SYNTAX. The default state of the square bracket
80 '(eval-when (:compile-toplevel :load-toplevel :execute)
81 (if *restore-sql-reader-syntax*
82 (%enable-sql-reader-syntax)
83 (%disable-sql-reader-syntax))))
85 (defun sql-reader-open (stream char)
86 (declare (ignore char))
87 (let ((sqllist (read-delimited-list #\] stream t)))
88 (if (sql-operator (car sqllist))
89 (cons (sql-operator (car sqllist)) (cdr sqllist))
90 (apply #'generate-sql-reference sqllist))))
92 ;; Internal function that disables the close syntax when leaving sql context.
93 (defun disable-sql-close-syntax ()
94 (set-macro-character *sql-macro-close-char* *original-reader-exit*)
95 (setf *original-reader-exit* nil))
97 ;; Internal function that enables close syntax when entering SQL context.
98 (defun enable-sql-close-syntax ()
99 (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*))
100 (set-macro-character *sql-macro-close-char* (get-macro-character #\))))
102 (defun generate-sql-reference (&rest arglist)
103 (cond ((= (length arglist) 1) ; string, table or attribute
104 (if (stringp (car arglist))
105 (sql-expression :string (car arglist))
106 (sql-expression :attribute (car arglist))))
107 ((<= 2 (length arglist))
108 (let ((sqltype (if (keywordp (caddr arglist))
109 (caddr arglist) nil))
110 (sqlparam (if (keywordp (caddr arglist))
113 ((stringp (cadr arglist))
114 (sql-expression :table (car arglist)
115 :alias (cadr arglist)
117 ((keywordp (cadr arglist))
118 (sql-expression :attribute (car arglist)
122 (sql-expression :attribute (cadr arglist)
127 (error 'clsql-sql-syntax-error :reason "bad expression syntax"))))
130 ;; Exported functions for dealing with SQL syntax
132 (defun sql (&rest args)
133 "Generates SQL from a set of expressions given by ARGS. Each
134 argument is translated into SQL and then the args are concatenated
135 with a single space between each pair."
136 (format nil "~{~A~^ ~}" (mapcar #'sql-output args)))
138 (defun sql-expression (&key string table alias attribute type params)
139 "Generates an SQL expression from the given keywords. Valid
140 combinations of the arguments are: string; table; table and alias;
141 table and attribute; table, attribute, and type; table or alias, and
142 attribute; table or alias, and attribute and type; attribute; and
146 (make-instance 'sql :string string))
148 (make-instance 'sql-ident-attribute :name attribute
149 :qualifier (or table alias)
152 ((and table (not attribute))
153 (make-instance 'sql-ident-table :name table
154 :table-alias alias))))
156 (defun sql-operator (operation)
157 "Takes an SQL operator as an argument and returns the Lisp symbol
161 (symbol (gethash (symbol-name-default-case (symbol-name operation))
164 (defun sql-operation (operation &rest rest)
165 "Generates an SQL statement from an operator and arguments."
166 (if (sql-operator operation)
167 (apply (symbol-function (sql-operator operation)) rest)
168 (error "~A is not a recognized SQL operator." operation)))