1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
4 ;;;; Definition of SQL operations used with the symbolic SQL syntax.
6 ;;;; This file is part of CLSQL.
8 ;;;; CLSQL users are granted the rights to distribute and use this software
9 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
10 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
11 ;;;; *************************************************************************
13 (in-package #:clsql-sys)
15 ;; Keep a hashtable for mapping symbols to sql generator functions,
16 ;; for use by the bracketed reader syntax.
18 (defvar *sql-op-table* (make-hash-table :test #'equal))
21 ;; Define an SQL operation type.
23 (defmacro defsql (function definition-keys &body body)
25 (defun ,function ,@body)
26 (let ((symbol (cadr (member :symbol ',definition-keys))))
27 (setf (gethash (if symbol (symbol-name-default-case symbol) ',function)
34 (defsql sql-query (:symbol "select") (&rest args)
35 (apply #'make-query args))
37 (defsql sql-any (:symbol "any") (&rest rest)
38 (make-instance 'sql-function-exp
39 :name 'any :args rest))
41 (defsql sql-some (:symbol "some") (&rest rest)
42 (make-instance 'sql-function-exp
43 :name 'some :args rest))
45 (defsql sql-all (:symbol "all") (&rest rest)
46 (make-instance 'sql-function-exp
47 :name 'all :args rest))
49 (defsql sql-not (:symbol "not") (&rest rest)
50 (make-instance 'sql-value-exp
51 :modifier 'not :components rest))
53 (defsql sql-union (:symbol "union") (&rest rest)
54 (make-instance 'sql-set-exp
55 :operator 'union :sub-expressions rest))
57 (defsql sql-intersect (:symbol "intersect") (&rest rest)
58 (make-instance 'sql-set-exp
59 :operator 'intersect :sub-expressions rest))
61 (defsql sql-except (:symbol "except") (&rest rest)
62 (make-instance 'sql-set-exp
63 :operator 'except :sub-expressions rest))
65 (defsql sql-minus (:symbol "minus") (&rest rest)
66 (make-instance 'sql-set-exp
67 :operator 'minus :sub-expressions rest))
69 (defsql sql-limit (:symbol "limit") (&rest rest)
70 (make-instance 'sql-query-modifier-exp
71 :modifier 'limit :components rest))
73 (defsql sql-group-by (:symbol "group-by") (&rest rest)
74 (make-instance 'sql-query-modifier-exp
75 :modifier '|GROUP BY| :components rest))
77 (defsql sql-order-by (:symbol "order-by") (&rest rest)
78 (make-instance 'sql-query-modifier-exp
79 :modifier '|ORDER BY| :components rest))
81 (defsql sql-having (:symbol "having") (&rest rest)
82 (make-instance 'sql-query-modifier-exp
83 :modifier 'having :components rest))
85 (defsql sql-null (:symbol "null") (&rest rest)
87 (make-instance 'sql-relational-exp :operator 'is
88 :sub-expressions (list (car rest) nil))
89 (make-instance 'sql-value-exp :components 'null)))
91 (defsql sql-not-null (:symbol "not-null") ()
92 (make-instance 'sql-value-exp
93 :components '|NOT NULL|))
95 (defsql sql-exists (:symbol "exists") (&rest rest)
96 (make-instance 'sql-function-exp
97 :name 'exists :args rest))
99 (defsql sql-* (:symbol "*") (&rest rest)
100 (if (zerop (length rest))
101 (make-instance 'sql-ident :name '*)
102 (make-instance 'sql-relational-exp :operator '* :sub-expressions rest)))
104 (defsql sql-+ (:symbol "+") (&rest rest)
106 (make-instance 'sql-relational-exp
107 :operator '+ :sub-expressions rest)
108 (make-instance 'sql-value-exp :modifier '+ :components rest)))
110 (defsql sql-/ (:symbol "/") (&rest rest)
111 (make-instance 'sql-relational-exp
112 :operator '/ :sub-expressions rest))
114 (defsql sql-- (:symbol "-") (&rest rest)
116 (make-instance 'sql-relational-exp
117 :operator '- :sub-expressions rest)
118 (make-instance 'sql-value-exp :modifier '- :components rest)))
120 (defsql sql-like (:symbol "like") (&rest rest)
121 (make-instance 'sql-relational-exp
122 :operator 'like :sub-expressions rest))
124 (defsql sql-uplike (:symbol "uplike") (&rest rest)
125 (make-instance 'sql-upcase-like
126 :sub-expressions rest))
128 (defsql sql-and (:symbol "and") (&rest rest)
129 (make-instance 'sql-relational-exp
130 :operator 'and :sub-expressions rest))
132 (defsql sql-or (:symbol "or") (&rest rest)
133 (make-instance 'sql-relational-exp
134 :operator 'or :sub-expressions rest))
136 (defsql sql-in (:symbol "in") (&rest rest)
137 (make-instance 'sql-relational-exp
138 :operator 'in :sub-expressions rest))
140 (defsql sql-concat-op (:symbol "concat-op") (&rest rest)
141 (make-instance 'sql-relational-exp
142 :operator '\|\| :sub-expressions rest))
144 (defsql sql-concat (:symbol "concat") (&rest rest)
145 (make-instance 'sql-function-exp
146 :name 'concat :args rest))
148 (defsql sql-substr (:symbol "substr") (&rest rest)
149 (if (= (length rest) 3)
150 (make-instance 'sql-function-exp
151 :name 'substr :args rest)
152 (error 'sql-user-error :message "SUBSTR must have 3 arguments.")))
154 (defsql sql-substring (:symbol "substring") (&rest rest)
155 (if (= (length rest) 3)
156 (make-instance 'sql-function-exp
157 :name 'substring :args rest)
158 (error 'sql-user-error :message "SUBSTRING must have 3 arguments.")))
160 (defsql sql-is (:symbol "is") (&rest rest)
161 (make-instance 'sql-relational-exp
162 :operator 'is :sub-expressions rest))
164 (defsql sql-= (:symbol "=") (&rest rest)
165 (make-instance 'sql-relational-exp
166 :operator '= :sub-expressions rest))
168 (defsql sql-== (:symbol "==") (&rest rest)
169 (make-instance 'sql-assignment-exp
170 :operator '= :sub-expressions rest))
172 (defsql sql-< (:symbol "<") (&rest rest)
173 (make-instance 'sql-relational-exp
174 :operator '< :sub-expressions rest))
177 (defsql sql-> (:symbol ">") (&rest rest)
178 (make-instance 'sql-relational-exp
179 :operator '> :sub-expressions rest))
181 (defsql sql-<> (:symbol "<>") (&rest rest)
182 (make-instance 'sql-relational-exp
183 :operator '<> :sub-expressions rest))
185 (defsql sql->= (:symbol ">=") (&rest rest)
186 (make-instance 'sql-relational-exp
187 :operator '>= :sub-expressions rest))
189 (defsql sql-<= (:symbol "<=") (&rest rest)
190 (make-instance 'sql-relational-exp
191 :operator '<= :sub-expressions rest))
193 (defsql sql-count (:symbol "count") (&rest rest)
194 (make-instance 'sql-function-exp
195 :name 'count :args rest))
197 (defsql sql-max (:symbol "max") (&rest rest)
198 (make-instance 'sql-function-exp
199 :name 'max :args rest))
201 (defsql sql-min (:symbol "min") (&rest rest)
202 (make-instance 'sql-function-exp
203 :name 'min :args rest))
205 (defsql sql-avg (:symbol "avg") (&rest rest)
206 (make-instance 'sql-function-exp
207 :name 'avg :args rest))
209 (defsql sql-sum (:symbol "sum") (&rest rest)
210 (make-instance 'sql-function-exp
211 :name 'sum :args rest))
213 (defsql sql-the (:symbol "the") (&rest rest)
214 (make-instance 'sql-typecast-exp
215 :modifier (first rest) :components (second rest)))
217 (defsql sql-function (:symbol "function") (&rest args)
218 (make-instance 'sql-function-exp
219 :name (make-symbol (car args)) :args (cdr args)))
221 (defsql sql-between (:symbol "between") (&rest rest)
222 (if (= (length rest) 3)
223 (make-instance 'sql-between-exp :name 'between :args rest)
224 (error 'sql-user-error :message "BETWEEN must have 3 arguments.")))
226 (defsql sql-distinct (:symbol "distinct") (&rest rest)
227 (make-instance 'sql-query-modifier-exp :modifier 'distinct
230 (defsql sql-coalesce (:symbol "coalesce") (&rest rest)
231 (make-instance 'sql-function-exp
232 :name 'coalesce :args rest))
234 (defsql sql-nvl (:symbol "nvl") (&rest rest)
235 (if (= (length rest) 2)
236 (make-instance 'sql-function-exp
237 :name 'coalesce :args rest)
238 (error 'sql-user-error :message "NVL accepts exactly 2 arguments.")))
240 (defsql sql-userenv (:symbol "userenv") (&rest rest)
241 (make-instance 'sql-function-exp
242 :name 'userenv :args rest))
244 (defsql sql-lower (:symbol "lower") (&rest rest)
245 (if (= (length rest) 1)
246 (make-instance 'sql-function-exp
247 :name 'lower :args rest)
248 (error 'sql-user-error :message "LOWER must have 1 argument.")))
250 (defsql sql-upper (:symbol "upper") (&rest rest)
251 (if (= (length rest) 1)
252 (make-instance 'sql-function-exp
253 :name 'upper :args rest)
254 (error 'sql-user-error :message "UPPER must have 1 argument.")))