1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; The CLSQL Functional Data Manipulation Language (FDML).
8 ;;;; This file is part of CLSQL.
10 ;;;; CLSQL users are granted the rights to distribute and use this software
11 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
12 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
13 ;;;; *************************************************************************
15 (in-package #:clsql-sys
)
17 ;;; Basic operations on databases
19 (defmethod database-query-result-set ((expr %sql-expression
) database
20 &key full-set result-types
)
21 (database-query-result-set (sql-output expr database
) database
22 :full-set full-set
:result-types result-types
))
24 (defmethod execute-command ((sql-expression string
)
25 &key
(database *default-database
*))
26 (record-sql-command sql-expression database
)
27 (let ((res (database-execute-command sql-expression database
)))
28 (record-sql-result res database
))
31 (defmethod execute-command ((expr %sql-expression
)
32 &key
(database *default-database
*))
33 (execute-command (sql-output expr database
) :database database
)
36 (defmethod query ((query-expression string
) &key
(database *default-database
*)
37 (result-types :auto
) (flatp nil
) (field-names t
))
38 (record-sql-command query-expression database
)
39 (multiple-value-bind (rows names
)
40 (database-query query-expression database result-types field-names
)
41 (let ((result (if (and flatp
(= 1 (length (car rows
))))
44 (record-sql-result result database
)
49 (defmethod query ((expr %sql-expression
) &key
(database *default-database
*)
50 (result-types :auto
) (flatp nil
) (field-names t
))
51 (query (sql-output expr database
) :database database
:flatp flatp
52 :result-types result-types
:field-names field-names
))
54 (defmethod query ((expr sql-object-query
) &key
(database *default-database
*)
55 (result-types :auto
) (flatp nil
) (field-names t
))
56 (declare (ignore result-types field-names
))
57 (apply #'select
(append (slot-value expr
'objects
)
58 (slot-value expr
'exp
)
59 (when (slot-value expr
'refresh
)
60 (list :refresh
(sql-output expr database
)))
61 (when (or flatp
(slot-value expr
'flatp
) )
63 (list :database database
))))
66 (defun print-query (query-exp &key titles
(formats t
) (sizes t
) (stream t
)
67 (database *default-database
*))
68 "Prints a tabular report of the results returned by the SQL
69 query QUERY-EXP, which may be a symbolic SQL expression or a
70 string, in DATABASE which defaults to *DEFAULT-DATABASE*. The
71 report is printed onto STREAM which has a default value of t
72 which means that *STANDARD-OUTPUT* is used. The TITLE argument,
73 which defaults to nil, allows the specification of a list of
74 strings to use as column titles in the tabular output. SIZES
75 accepts a list of column sizes, one for each column selected by
76 QUERY-EXP, to use in formatting the tabular report. The default
77 value of t means that minimum sizes are computed. FORMATS is a
78 list of format strings to be used for printing each column
79 selected by QUERY-EXP. The default value of FORMATS is t meaning
80 that ~A is used to format all columns or ~VA if column sizes are
82 (flet ((compute-sizes (data)
84 (apply #'max
(mapcar #'(lambda (y)
85 (if (null y
) 3 (length y
)))
87 (apply #'mapcar
(cons #'list data
))))
88 (format-record (record control sizes
)
89 (format stream
"~&~?" control
90 (if (null sizes
) record
91 (mapcan #'(lambda (s f
) (list s f
)) sizes record
)))))
92 (let* ((query-exp (etypecase query-exp
94 (sql-query (sql-output query-exp database
))))
95 (data (query query-exp
:database database
:result-types nil
97 (sizes (if (or (null sizes
) (listp sizes
)) sizes
98 (compute-sizes (if titles
(cons titles data
) data
))))
99 (formats (if (or (null formats
) (not (listp formats
)))
100 (make-list (length (car data
)) :initial-element
101 (if (null sizes
) "~A " "~VA "))
103 (control-string (format nil
"~{~A~}" formats
)))
104 (when titles
(format-record titles control-string sizes
))
105 (dolist (d data
(values)) (format-record d control-string sizes
)))))
107 (defun insert-records (&key
(into nil
)
112 (database *default-database
*))
113 "Inserts records into the table specified by INTO in DATABASE
114 which defaults to *DEFAULT-DATABASE*. There are five ways of
115 specifying the values inserted into each row. In the first VALUES
116 contains a list of values to insert and ATTRIBUTES, AV-PAIRS and
117 QUERY are nil. This can be used when values are supplied for all
118 attributes in INTO. In the second, ATTRIBUTES is a list of column
119 names, VALUES is a corresponding list of values and AV-PAIRS and
120 QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil
121 and AV-PAIRS is an alist of (attribute value) pairs. In the
122 fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a
123 symbolic SQL query expression in which the selected columns also
124 exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil
125 and ATTRIBUTES is a list of column names and QUERY is a symbolic
126 SQL query expression which returns values for the specified
128 (let ((stmt (make-sql-insert :into into
:attrs attributes
129 :vals values
:av-pairs av-pairs
131 (execute-command stmt
:database database
)))
133 (defun make-sql-insert (&key
(into nil
)
139 (error 'sql-user-error
:message
":into keyword not supplied"))
140 (let ((insert (make-instance 'sql-insert
:into into
)))
141 (with-slots (attributes values query
)
143 (cond ((and vals
(not attrs
) (not query
) (not av-pairs
))
145 ((and vals attrs
(not subquery
) (not av-pairs
))
146 (setf attributes attrs
)
148 ((and av-pairs
(not vals
) (not attrs
) (not subquery
))
149 (setf attributes
(mapcar #'car av-pairs
))
150 (setf values
(mapcar #'cadr av-pairs
)))
151 ((and subquery
(not vals
) (not attrs
) (not av-pairs
))
152 (setf query subquery
))
153 ((and subquery attrs
(not vals
) (not av-pairs
))
154 (setf attributes attrs
)
155 (setf query subquery
))
157 (error 'sql-user-error
158 :message
"bad or ambiguous keyword combination.")))
161 (defun delete-records (&key
(from nil
)
163 (database *default-database
*))
164 "Deletes records satisfying the SQL expression WHERE from the
165 table specified by FROM in DATABASE specifies a database which
166 defaults to *DEFAULT-DATABASE*."
167 (let ((stmt (make-instance 'sql-delete
:from from
:where where
)))
168 (execute-command stmt
:database database
)))
170 (defun update-records (table &key
(attributes nil
)
174 (database *default-database
*))
175 "Updates the attribute values of existing records satsifying
176 the SQL expression WHERE in the table specified by TABLE in
177 DATABASE which defaults to *DEFAULT-DATABASE*. There are three
178 ways of specifying the values to update for each row. In the
179 first, VALUES contains a list of values to use in the update and
180 ATTRIBUTES and AV-PAIRS are nil. This can be used when values are
181 supplied for all attributes in TABLE. In the second, ATTRIBUTES
182 is a list of column names, VALUES is a corresponding list of
183 values and AV-PAIRS is nil. In the third, ATTRIBUTES and VALUES
184 are nil and AV-PAIRS is an alist of (attribute value) pairs."
186 (setf attributes
(mapcar #'car av-pairs
)
187 values
(mapcar #'cadr av-pairs
)))
188 (let ((stmt (make-instance 'sql-update
:table table
189 :attributes attributes
192 (execute-command stmt
:database database
)))
197 (defmacro do-query
(((&rest args
) query-expression
198 &key
(database '*default-database
*) (result-types :auto
))
200 "Repeatedly executes BODY within a binding of ARGS on the
201 fields of each row selected by the SQL query QUERY-EXPRESSION,
202 which may be a string or a symbolic SQL expression, in DATABASE
203 which defaults to *DEFAULT-DATABASE*. The values returned by the
204 execution of BODY are returned. RESULT-TYPES is a list of symbols
205 which specifies the lisp type for each field returned by
206 QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned
207 as strings whereas the default value of :auto means that the lisp
208 types are automatically computed for each field."
209 (let ((result-set (gensym "RESULT-SET-"))
210 (qe (gensym "QUERY-EXPRESSION-"))
211 (columns (gensym "COLUMNS-"))
212 (row (gensym "ROW-"))
214 `(let ((,qe
,query-expression
))
217 (dolist (,row
(query ,qe
))
218 (destructuring-bind ,args
223 (let ((,db
,database
))
224 (multiple-value-bind (,result-set
,columns
)
225 (database-query-result-set ,qe
,db
227 :result-types
,result-types
)
230 (do ((,row
(make-list ,columns
)))
231 ((not (database-store-next-row ,result-set
,db
,row
))
233 (destructuring-bind ,args
,row
235 (database-dump-result-set ,result-set
,db
))))))))))
237 (defun map-query (output-type-spec function query-expression
238 &key
(database *default-database
*)
239 (result-types :auto
))
240 "Map the function FUNCTION over the attribute values of each
241 row selected by the SQL query QUERY-EXPRESSION, which may be a
242 string or a symbolic SQL expression, in DATABASE which defaults
243 to *DEFAULT-DATABASE*. The results of the function are collected
244 as specified in OUTPUT-TYPE-SPEC and returned like in
245 MAP. RESULT-TYPES is a list of symbols which specifies the lisp
246 type for each field returned by QUERY-EXPRESSION. If RESULT-TYPES
247 is nil all results are returned as strings whereas the default
248 value of :auto means that the lisp types are automatically
249 computed for each field."
250 (typecase query-expression
252 (map output-type-spec
#'(lambda (x) (apply function x
))
253 (query query-expression
)))
256 (macrolet ((type-specifier-atom (type)
257 `(if (atom ,type
) ,type
(car ,type
))))
258 (case (type-specifier-atom output-type-spec
)
260 (map-query-for-effect function query-expression database
263 (map-query-to-list function query-expression database result-types
))
264 ((simple-vector simple-string vector string array simple-array
265 bit-vector simple-bit-vector base-string
267 (map-query-to-simple output-type-spec function query-expression
268 database result-types
))
271 (cmucl-compat:result-type-or-lose output-type-spec t
)
272 function query-expression
:database database
273 :result-types result-types
)))))))
275 (defun map-query-for-effect (function query-expression database result-types
)
276 (multiple-value-bind (result-set columns
)
277 (database-query-result-set query-expression database
:full-set nil
278 :result-types result-types
)
279 (let ((flatp (and (= columns
1)
280 (typep query-expression
'sql-query
)
281 (slot-value query-expression
'flatp
))))
284 (do ((row (make-list columns
)))
285 ((not (database-store-next-row result-set database row
))
289 (funcall function row
)))
290 (database-dump-result-set result-set database
))))))
292 (defun map-query-to-list (function query-expression database result-types
)
293 (multiple-value-bind (result-set columns
)
294 (database-query-result-set query-expression database
:full-set nil
295 :result-types result-types
)
296 (let ((flatp (and (= columns
1)
297 (typep query-expression
'sql-query
)
298 (slot-value query-expression
'flatp
))))
301 (let ((result (list nil
)))
302 (do ((row (make-list columns
))
303 (current-cons result
(cdr current-cons
)))
304 ((not (database-store-next-row result-set database row
))
309 (funcall function
(copy-list row
)))))))
310 (database-dump-result-set result-set database
))))))
312 (defun map-query-to-simple (output-type-spec function query-expression database result-types
)
313 (multiple-value-bind (result-set columns rows
)
314 (database-query-result-set query-expression database
:full-set t
315 :result-types result-types
)
316 (let ((flatp (and (= columns
1)
317 (typep query-expression
'sql-query
)
318 (slot-value query-expression
'flatp
))))
322 ;; We know the row count in advance, so we allocate once
324 (cmucl-compat:make-sequence-of-type output-type-spec rows
))
325 (row (make-list columns
))
326 (index 0 (1+ index
)))
327 ((not (database-store-next-row result-set database row
))
329 (declare (fixnum index
))
330 (setf (aref result index
)
333 (funcall function
(copy-list row
)))))
334 ;; Database can't report row count in advance, so we have
335 ;; to grow and shrink our vector dynamically
337 (cmucl-compat:make-sequence-of-type output-type-spec
100))
338 (allocated-length 100)
339 (row (make-list columns
))
340 (index 0 (1+ index
)))
341 ((not (database-store-next-row result-set database row
))
342 (cmucl-compat:shrink-vector result index
))
343 (declare (fixnum allocated-length index
))
344 (when (>= index allocated-length
)
345 (setq allocated-length
(* allocated-length
2)
346 result
(adjust-array result allocated-length
)))
347 (setf (aref result index
)
350 (funcall function
(copy-list row
))))))
351 (database-dump-result-set result-set database
))))))
353 ;;; Row processing macro from CLSQL
355 (defmacro for-each-row
(((&rest fields
) &key from order-by where distinct limit
)
357 (let ((d (gensym "DISTINCT-"))
358 (bind-fields (loop for f in fields collect
(car f
)))
359 (w (gensym "WHERE-"))
360 (o (gensym "ORDER-BY-"))
361 (frm (gensym "FROM-"))
362 (l (gensym "LIMIT-"))
363 (q (gensym "QUERY-")))
369 (let ((,q
(query-string ',fields
,frm
,w
,d
,o
,l
)))
370 (loop for tuple in
(query ,q
)
371 collect
(destructuring-bind ,bind-fields tuple
374 (defun query-string (fields from where distinct order-by limit
)
377 (format nil
"select ~A~{~A~^,~} from ~{~A~^ and ~}"
378 (if distinct
"distinct " "") (field-names fields
)
380 (if where
(format nil
" where ~{~A~^ ~}"
381 (where-strings where
)) "")
382 (if order-by
(format nil
" order by ~{~A~^, ~}"
383 (order-by-strings order-by
)))
384 (if limit
(format nil
" limit ~D" limit
) "")))
386 (defun lisp->sql-name
(field)
389 (symbol (string-upcase (symbol-name field
)))
391 (t (format nil
"~A" field
))))
393 (defun field-names (field-forms)
394 "Return a list of field name strings from a fields form"
395 (loop for field-form in field-forms
398 (if (cadr field-form
)
402 (defun from-names (from)
403 "Return a list of field name strings from a fields form"
404 (loop for table in
(if (atom from
) (list from
) from
)
405 collect
(lisp->sql-name table
)))
408 (defun where-strings (where)
409 (loop for w in
(if (atom (car where
)) (list where
) where
)
412 (format nil
"~A ~A ~A" (second w
) (first w
) (third w
))
413 (format nil
"~A" w
))))
415 (defun order-by-strings (order-by)
416 (loop for o in order-by
420 (format nil
"~A ~A" (lisp->sql-name
(car o
))
421 (lisp->sql-name
(cadr o
))))))
424 ;;; Large objects support
426 (defun create-large-object (&key
(database *default-database
*))
427 "Creates a new large object in the database and returns the object identifier"
428 (database-create-large-object database
))
430 (defun write-large-object (object-id data
&key
(database *default-database
*))
431 "Writes data to the large object"
432 (database-write-large-object object-id data database
))
434 (defun read-large-object (object-id &key
(database *default-database
*))
435 "Reads the large object content"
436 (database-read-large-object object-id database
))
438 (defun delete-large-object (object-id &key
(database *default-database
*))
439 "Deletes the large object in the database"
440 (database-delete-large-object object-id database
))
443 ;;; Prepared statements
445 (defun prepare-sql (sql-stmt types
&key
(database *default-database
*) (result-types :auto
) field-names
)
446 "Prepares a SQL statement for execution. TYPES contains a
447 list of types corresponding to the input parameters. Returns a
448 prepared-statement object.
457 (unless (db-type-has-prepared-stmt?
(database-type database
))
458 (error 'sql-user-error
461 "Database backend type ~:@(~A~) does not support prepared statements."
462 (database-type database
))))
464 (database-prepare sql-stmt types database result-types field-names
))
466 (defun bind-parameter (prepared-stmt position value
)
467 "Sets the value of a parameter is in prepared statement."
468 (database-bind-parameter prepared-stmt position value
)
471 (defun run-prepared-sql (prepared-stmt)
472 "Execute the prepared sql statment. All input parameters must be bound."
473 (database-run-prepared prepared-stmt
))
475 (defun free-prepared-sql (prepared-stmt)
476 "Delete the objects associated with a prepared statement."
477 (database-free-prepared prepared-stmt
))