1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
4 ;;;; The CLSQL Functional Data Manipulation Language (FDML).
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 ;;; Basic operations on databases
17 (defmethod database-query-result-set ((expr %sql-expression
) database
18 &key full-set result-types
)
19 (database-query-result-set (sql-output expr database
) database
20 :full-set full-set
:result-types result-types
))
22 (defmethod execute-command ((sql-expression string
)
23 &key
(database *default-database
*))
24 (record-sql-command sql-expression database
)
25 (let ((res (database-execute-command sql-expression database
)))
26 (record-sql-result res database
))
29 (defmethod execute-command ((expr %sql-expression
)
30 &key
(database *default-database
*))
31 (execute-command (sql-output expr database
) :database database
)
34 (defmethod query ((query-expression string
) &key
(database *default-database
*)
35 (result-types :auto
) (flatp nil
) (field-names t
))
36 (record-sql-command query-expression database
)
37 (multiple-value-bind (rows names
)
38 (database-query query-expression database result-types field-names
)
39 (let ((result (if (and flatp
(= 1 (length (car rows
))))
42 (record-sql-result result database
)
47 (defmethod query ((expr %sql-expression
) &key
(database *default-database
*)
48 (result-types :auto
) (flatp nil
) (field-names t
))
49 (query (sql-output expr database
) :database database
:flatp flatp
50 :result-types result-types
:field-names field-names
))
52 (defmethod query ((expr sql-object-query
) &key
(database *default-database
*)
53 (result-types :auto
) (flatp nil
) (field-names t
))
54 (declare (ignore result-types field-names
))
55 (apply #'select
(append (slot-value expr
'objects
)
56 (slot-value expr
'exp
)
57 (when (slot-value expr
'refresh
)
58 (list :refresh
(sql-output expr database
)))
59 (when (or flatp
(slot-value expr
'flatp
) )
61 (list :database database
))))
64 (defun print-query (query-exp &key titles
(formats t
) (sizes t
) (stream t
)
65 (database *default-database
*))
66 "Prints a tabular report of the results returned by the SQL
67 query QUERY-EXP, which may be a symbolic SQL expression or a
68 string, in DATABASE which defaults to *DEFAULT-DATABASE*. The
69 report is printed onto STREAM which has a default value of t
70 which means that *STANDARD-OUTPUT* is used. The TITLE argument,
71 which defaults to nil, allows the specification of a list of
72 strings to use as column titles in the tabular output. SIZES
73 accepts a list of column sizes, one for each column selected by
74 QUERY-EXP, to use in formatting the tabular report. The default
75 value of t means that minimum sizes are computed. FORMATS is a
76 list of format strings to be used for printing each column
77 selected by QUERY-EXP. The default value of FORMATS is t meaning
78 that ~A is used to format all columns or ~VA if column sizes are
80 (flet ((compute-sizes (data)
82 (apply #'max
(mapcar #'(lambda (y)
83 (if (null y
) 3 (length y
)))
85 (apply #'mapcar
(cons #'list data
))))
86 (format-record (record control sizes
)
87 (format stream
"~&~?" control
88 (if (null sizes
) record
89 (mapcan #'(lambda (s f
) (list s f
)) sizes record
)))))
90 (let* ((query-exp (etypecase query-exp
92 (sql-query (sql-output query-exp database
))))
93 (data (query query-exp
:database database
:result-types nil
95 (sizes (if (or (null sizes
) (listp sizes
)) sizes
96 (compute-sizes (if titles
(cons titles data
) data
))))
97 (formats (if (or (null formats
) (not (listp formats
)))
98 (make-list (length (car data
)) :initial-element
99 (if (null sizes
) "~A " "~VA "))
101 (control-string (format nil
"~{~A~}" formats
)))
102 (when titles
(format-record titles control-string sizes
))
103 (dolist (d data
(values)) (format-record d control-string sizes
)))))
105 (defun insert-records (&key
(into nil
)
110 (database *default-database
*))
111 "Inserts records into the table specified by INTO in DATABASE
112 which defaults to *DEFAULT-DATABASE*. There are five ways of
113 specifying the values inserted into each row. In the first VALUES
114 contains a list of values to insert and ATTRIBUTES, AV-PAIRS and
115 QUERY are nil. This can be used when values are supplied for all
116 attributes in INTO. In the second, ATTRIBUTES is a list of column
117 names, VALUES is a corresponding list of values and AV-PAIRS and
118 QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil
119 and AV-PAIRS is an alist of (attribute value) pairs. In the
120 fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a
121 symbolic SQL query expression in which the selected columns also
122 exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil
123 and ATTRIBUTES is a list of column names and QUERY is a symbolic
124 SQL query expression which returns values for the specified
126 (let ((stmt (make-sql-insert :into into
:attrs attributes
127 :vals values
:av-pairs av-pairs
129 (execute-command stmt
:database database
)))
131 (defun make-sql-insert (&key
(into nil
)
137 (error 'sql-user-error
:message
":into keyword not supplied"))
138 (let ((insert (make-instance 'sql-insert
:into into
)))
139 (with-slots (attributes values query
)
142 (cond ((and vals
(not attrs
) (not query
) (not av-pairs
))
144 ((and vals attrs
(not subquery
) (not av-pairs
))
145 (setf attributes attrs
)
147 ((and av-pairs
(not vals
) (not attrs
) (not subquery
))
148 (setf attributes
(mapcar #'car av-pairs
))
149 (setf values
(mapcar #'cadr av-pairs
)))
150 ((and subquery
(not vals
) (not attrs
) (not av-pairs
))
151 (setf query subquery
))
152 ((and subquery attrs
(not vals
) (not av-pairs
))
153 (setf attributes attrs
)
154 (setf query subquery
))
156 (error 'sql-user-error
157 :message
"bad or ambiguous keyword combination.")))
160 (defun delete-records (&key
(from nil
)
162 (database *default-database
*))
163 "Deletes records satisfying the SQL expression WHERE from the
164 table specified by FROM in DATABASE specifies a database which
165 defaults to *DEFAULT-DATABASE*."
166 (let ((stmt (make-instance 'sql-delete
:from from
:where where
)))
167 (execute-command stmt
:database database
)))
169 (defun update-records (table &key
(attributes nil
)
173 (database *default-database
*))
174 "Updates the attribute values of existing records satsifying
175 the SQL expression WHERE in the table specified by TABLE in
176 DATABASE which defaults to *DEFAULT-DATABASE*. There are three
177 ways of specifying the values to update for each row. In the
178 first, VALUES contains a list of values to use in the update and
179 ATTRIBUTES and AV-PAIRS are nil. This can be used when values are
180 supplied for all attributes in TABLE. In the second, ATTRIBUTES
181 is a list of column names, VALUES is a corresponding list of
182 values and AV-PAIRS is nil. In the third, ATTRIBUTES and VALUES
183 are nil and AV-PAIRS is an alist of (attribute value) pairs."
185 (setf attributes
(mapcar #'car av-pairs
)
186 values
(mapcar #'cadr av-pairs
)))
187 (let ((stmt (make-instance 'sql-update
:table table
188 :attributes attributes
191 (execute-command stmt
:database database
)))
196 (defmacro do-query
(((&rest args
) query-expression
197 &key
(database '*default-database
*) (result-types :auto
))
199 "Repeatedly executes BODY within a binding of ARGS on the
200 fields of each row selected by the SQL query QUERY-EXPRESSION,
201 which may be a string or a symbolic SQL expression, in DATABASE
202 which defaults to *DEFAULT-DATABASE*. The values returned by the
203 execution of BODY are returned. RESULT-TYPES is a list of symbols
204 which specifies the lisp type for each field returned by
205 QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned
206 as strings whereas the default value of :auto means that the lisp
207 types are automatically computed for each field."
208 (let ((result-set (gensym "RESULT-SET-"))
209 (qe (gensym "QUERY-EXPRESSION-"))
210 (columns (gensym "COLUMNS-"))
211 (row (gensym "ROW-"))
213 `(let ((,qe
,query-expression
)
217 (dolist (,row
(query ,qe
:database
,db
))
218 (destructuring-bind ,args
223 (multiple-value-bind (,result-set
,columns
)
224 (database-query-result-set ,qe
,db
226 :result-types
,result-types
)
229 (do ((,row
(make-list ,columns
)))
230 ((not (database-store-next-row ,result-set
,db
,row
))
232 (destructuring-bind ,args
,row
234 (database-dump-result-set ,result-set
,db
)))))))))
236 (defun map-query (output-type-spec function query-expression
237 &key
(database *default-database
*)
238 (result-types :auto
))
239 "Map the function FUNCTION over the attribute values of each
240 row selected by the SQL query QUERY-EXPRESSION, which may be a
241 string or a symbolic SQL expression, in DATABASE which defaults
242 to *DEFAULT-DATABASE*. The results of the function are collected
243 as specified in OUTPUT-TYPE-SPEC and returned like in
244 MAP. RESULT-TYPES is a list of symbols which specifies the lisp
245 type for each field returned by QUERY-EXPRESSION. If RESULT-TYPES
246 is nil all results are returned as strings whereas the default
247 value of :auto means that the lisp types are automatically
248 computed for each field."
249 (typecase query-expression
251 (map output-type-spec
#'(lambda (x) (apply function x
))
252 (query query-expression
)))
255 (macrolet ((type-specifier-atom (type)
256 `(if (atom ,type
) ,type
(car ,type
))))
257 (case (type-specifier-atom output-type-spec
)
259 (map-query-for-effect function query-expression database
262 (map-query-to-list function query-expression database result-types
))
263 ((simple-vector simple-string vector string array simple-array
264 bit-vector simple-bit-vector base-string
266 (map-query-to-simple output-type-spec function query-expression
267 database result-types
))
270 (cmucl-compat:result-type-or-lose output-type-spec t
)
271 function query-expression
:database database
272 :result-types result-types
)))))))
274 (defun map-query-for-effect (function query-expression database result-types
)
275 (multiple-value-bind (result-set columns
)
276 (database-query-result-set query-expression database
:full-set nil
277 :result-types result-types
)
278 (let ((flatp (and (= columns
1)
279 (typep query-expression
'sql-query
)
280 (slot-value query-expression
'flatp
))))
283 (do ((row (make-list columns
)))
284 ((not (database-store-next-row result-set database row
))
288 (funcall function row
)))
289 (database-dump-result-set result-set database
))))))
291 (defun map-query-to-list (function query-expression database result-types
)
292 (multiple-value-bind (result-set columns
)
293 (database-query-result-set query-expression database
:full-set nil
294 :result-types result-types
)
295 (let ((flatp (and (= columns
1)
296 (typep query-expression
'sql-query
)
297 (slot-value query-expression
'flatp
))))
300 (let ((result (list nil
)))
301 (do ((row (make-list columns
))
302 (current-cons result
(cdr current-cons
)))
303 ((not (database-store-next-row result-set database row
))
308 (funcall function
(copy-list row
)))))))
309 (database-dump-result-set result-set database
))))))
311 (defun map-query-to-simple (output-type-spec function query-expression database result-types
)
312 (multiple-value-bind (result-set columns rows
)
313 (database-query-result-set query-expression database
:full-set t
314 :result-types result-types
)
315 (let ((flatp (and (= columns
1)
316 (typep query-expression
'sql-query
)
317 (slot-value query-expression
'flatp
))))
321 ;; We know the row count in advance, so we allocate once
323 (cmucl-compat:make-sequence-of-type output-type-spec rows
))
324 (row (make-list columns
))
325 (index 0 (1+ index
)))
326 ((not (database-store-next-row result-set database row
))
328 (declare (fixnum index
))
329 (setf (aref result index
)
332 (funcall function
(copy-list row
)))))
333 ;; Database can't report row count in advance, so we have
334 ;; to grow and shrink our vector dynamically
336 (cmucl-compat:make-sequence-of-type output-type-spec
100))
337 (allocated-length 100)
338 (row (make-list columns
))
339 (index 0 (1+ index
)))
340 ((not (database-store-next-row result-set database row
))
341 (cmucl-compat:shrink-vector result index
))
342 (declare (fixnum allocated-length index
))
343 (when (>= index allocated-length
)
344 (setq allocated-length
(* allocated-length
2)
345 result
(adjust-array result allocated-length
)))
346 (setf (aref result index
)
349 (funcall function
(copy-list row
))))))
350 (database-dump-result-set result-set database
))))))
352 ;;; Row processing macro from CLSQL
354 (defmacro for-each-row
(((&rest fields
) &key from order-by where distinct limit
)
356 (let ((d (gensym "DISTINCT-"))
357 (bind-fields (loop for f in fields collect
(car f
)))
358 (w (gensym "WHERE-"))
359 (o (gensym "ORDER-BY-"))
360 (frm (gensym "FROM-"))
361 (l (gensym "LIMIT-"))
362 (q (gensym "QUERY-")))
368 (let ((,q
(query-string ',fields
,frm
,w
,d
,o
,l
)))
369 (loop for tuple in
(query ,q
)
370 collect
(destructuring-bind ,bind-fields tuple
373 (defun query-string (fields from where distinct order-by limit
)
376 (format nil
"select ~A~{~A~^,~} from ~{~A~^ and ~}"
377 (if distinct
"distinct " "") (field-names fields
)
379 (if where
(format nil
" where ~{~A~^ ~}"
380 (where-strings where
)) "")
381 (if order-by
(format nil
" order by ~{~A~^, ~}"
382 (order-by-strings order-by
)))
383 (if limit
(format nil
" limit ~D" limit
) "")))
385 (defun lisp->sql-name
(field)
388 (symbol (string-upcase (symbol-name field
)))
390 (t (format nil
"~A" field
))))
392 (defun field-names (field-forms)
393 "Return a list of field name strings from a fields form"
394 (loop for field-form in field-forms
397 (if (cadr field-form
)
401 (defun from-names (from)
402 "Return a list of field name strings from a fields form"
403 (loop for table in
(if (atom from
) (list from
) from
)
404 collect
(lisp->sql-name table
)))
407 (defun where-strings (where)
408 (loop for w in
(if (atom (car where
)) (list where
) where
)
411 (format nil
"~A ~A ~A" (second w
) (first w
) (third w
))
412 (format nil
"~A" w
))))
414 (defun order-by-strings (order-by)
415 (loop for o in order-by
419 (format nil
"~A ~A" (lisp->sql-name
(car o
))
420 (lisp->sql-name
(cadr o
))))))
423 ;;; Large objects support
425 (defun create-large-object (&key
(database *default-database
*))
426 "Creates a new large object in the database and returns the object identifier"
427 (database-create-large-object database
))
429 (defun write-large-object (object-id data
&key
(database *default-database
*))
430 "Writes data to the large object"
431 (database-write-large-object object-id data database
))
433 (defun read-large-object (object-id &key
(database *default-database
*))
434 "Reads the large object content"
435 (database-read-large-object object-id database
))
437 (defun delete-large-object (object-id &key
(database *default-database
*))
438 "Deletes the large object in the database"
439 (database-delete-large-object object-id database
))
442 ;;; Prepared statements
444 (defun prepare-sql (sql-stmt types
&key
(database *default-database
*) (result-types :auto
) field-names
)
445 "Prepares a SQL statement for execution. TYPES contains a
446 list of types corresponding to the input parameters. Returns a
447 prepared-statement object.
456 (unless (db-type-has-prepared-stmt?
(database-type database
))
457 (error 'sql-user-error
460 "Database backend type ~:@(~A~) does not support prepared statements."
461 (database-type database
))))
463 (database-prepare sql-stmt types database result-types field-names
))
465 (defun bind-parameter (prepared-stmt position value
)
466 "Sets the value of a parameter is in prepared statement."
467 (database-bind-parameter prepared-stmt position value
)
470 (defun run-prepared-sql (prepared-stmt)
471 "Execute the prepared sql statment. All input parameters must be bound."
472 (database-run-prepared prepared-stmt
))
474 (defun free-prepared-sql (prepared-stmt)
475 "Delete the objects associated with a prepared statement."
476 (database-free-prepared prepared-stmt
))