1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
6 ;;;; Base SQL functions
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-base)
19 (defgeneric query (query-expression &key database result-types flatp)
21 "Execute the SQL query expression QUERY-EXPRESSION on the given
22 DATABASE which defaults to *default-database*. RESULT-TYPES is a list
23 of symbols such as :string and :integer, one for each field in the
24 query, which are used to specify the types to return. The FLATP
25 argument, which has a default value of nil, specifies if full
26 bracketed results should be returned for each matched entry. If FLATP
27 is nil, the results are returned as a list of lists. If FLATP is t,
28 the results are returned as elements of a list, only if there is only
29 one result per row. Returns a list of lists of values of the result of
30 that expression and a list of field names selected in sql-exp."))
32 (defmethod query ((query-expression string) &key (database *default-database*)
33 (result-types :auto) (flatp nil) (field-names t))
34 (record-sql-action query-expression :query database)
35 (multiple-value-bind (rows names) (database-query query-expression database result-types
37 (let ((result (if (and flatp (= 1 (length (car rows))))
40 (record-sql-action result :result database)
47 (defgeneric execute-command (expression &key database)
49 "Executes the SQL command specified by EXPRESSION for the database
50 specified by DATABASE, which has a default value of
51 *DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement
52 other than a query. To run a stored procedure, pass an appropriate
53 string. The call to the procedure needs to be wrapped in a BEGIN END
56 (defmethod execute-command ((sql-expression string)
57 &key (database *default-database*))
58 (record-sql-action sql-expression :command database)
59 (let ((res (database-execute-command sql-expression database)))
60 (record-sql-action res :result database))
63 (defmacro do-query (((&rest args) query-expression
64 &key (database '*default-database*) (result-types :auto))
66 "Repeatedly executes BODY within a binding of ARGS on the
67 attributes of each record resulting from QUERY-EXPRESSION. The
68 return value is determined by the result of executing BODY. The
69 default value of DATABASE is *DEFAULT-DATABASE*."
70 (let ((result-set (gensym "RESULT-SET-"))
71 (qe (gensym "QUERY-EXPRESSION-"))
72 (columns (gensym "COLUMNS-"))
75 `(let ((,qe ,query-expression))
80 (destructuring-bind ,args
85 (let ((,db ,database))
86 (multiple-value-bind (,result-set ,columns)
87 (database-query-result-set ,qe ,db
89 :result-types ,result-types)
92 (do ((,row (make-list ,columns)))
93 ((not (database-store-next-row ,result-set ,db ,row))
95 (destructuring-bind ,args ,row
97 (database-dump-result-set ,result-set ,db))))))))))
99 (defun map-query (output-type-spec function query-expression
100 &key (database *default-database*)
101 (result-types :auto))
102 "Map the function over all tuples that are returned by the
103 query in QUERY-EXPRESSION. The results of the function are
104 collected as specified in OUTPUT-TYPE-SPEC and returned like in
106 (if (listp query-expression)
108 (map output-type-spec #'(lambda (x) (apply function x)) query-expression)
110 (macrolet ((type-specifier-atom (type)
111 `(if (atom ,type) ,type (car ,type))))
112 (case (type-specifier-atom output-type-spec)
114 (map-query-for-effect function query-expression database
117 (map-query-to-list function query-expression database result-types))
118 ((simple-vector simple-string vector string array simple-array
119 bit-vector simple-bit-vector base-string
121 (map-query-to-simple output-type-spec function query-expression
122 database result-types))
125 (cmucl-compat:result-type-or-lose output-type-spec t)
126 function query-expression :database database
127 :result-types result-types))))))
129 (defun map-query-for-effect (function query-expression database result-types)
130 (multiple-value-bind (result-set columns)
131 (database-query-result-set query-expression database :full-set nil
132 :result-types result-types)
135 (do ((row (make-list columns)))
136 ((not (database-store-next-row result-set database row))
138 (apply function row))
139 (database-dump-result-set result-set database)))))
141 (defun map-query-to-list (function query-expression database result-types)
142 (multiple-value-bind (result-set columns)
143 (database-query-result-set query-expression database :full-set nil
144 :result-types result-types)
147 (let ((result (list nil)))
148 (do ((row (make-list columns))
149 (current-cons result (cdr current-cons)))
150 ((not (database-store-next-row result-set database row))
152 (rplacd current-cons (list (apply function row)))))
153 (database-dump-result-set result-set database)))))
156 (defun map-query-to-simple (output-type-spec function query-expression database result-types)
157 (multiple-value-bind (result-set columns rows)
158 (database-query-result-set query-expression database :full-set t
159 :result-types result-types)
163 ;; We know the row count in advance, so we allocate once
165 (cmucl-compat:make-sequence-of-type output-type-spec rows))
166 (row (make-list columns))
167 (index 0 (1+ index)))
168 ((not (database-store-next-row result-set database row))
170 (declare (fixnum index))
171 (setf (aref result index)
172 (apply function row)))
173 ;; Database can't report row count in advance, so we have
174 ;; to grow and shrink our vector dynamically
176 (cmucl-compat:make-sequence-of-type output-type-spec 100))
177 (allocated-length 100)
178 (row (make-list columns))
179 (index 0 (1+ index)))
180 ((not (database-store-next-row result-set database row))
181 (cmucl-compat:shrink-vector result index))
182 (declare (fixnum allocated-length index))
183 (when (>= index allocated-length)
184 (setq allocated-length (* allocated-length 2)
185 result (adjust-array result allocated-length)))
186 (setf (aref result index)
187 (apply function row))))
188 (database-dump-result-set result-set database)))))
190 ;;; Large objects support
192 (defun create-large-object (&key (database *default-database*))
193 "Creates a new large object in the database and returns the object identifier"
194 (database-create-large-object database))
196 (defun write-large-object (object-id data &key (database *default-database*))
197 "Writes data to the large object"
198 (database-write-large-object object-id data database))
200 (defun read-large-object (object-id &key (database *default-database*))
201 "Reads the large object content"
202 (database-read-large-object object-id database))
204 (defun delete-large-object (object-id &key (database *default-database*))
205 "Deletes the large object in the database"
206 (database-delete-large-object object-id database))