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 nil))
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))
74 `(if (listp ,query-expression)
76 (dolist (,row ,query-expression)
77 (destructuring-bind ,args
81 (let ((,db ,database))
82 (multiple-value-bind (,result-set ,columns)
83 (database-query-result-set ,query-expression ,db
85 :result-types ,result-types)
88 (do ((,row (make-list ,columns)))
89 ((not (database-store-next-row ,result-set ,db ,row))
91 (destructuring-bind ,args ,row
93 (database-dump-result-set ,result-set ,db))))))))
95 (defun map-query (output-type-spec function query-expression
96 &key (database *default-database*)
98 "Map the function over all tuples that are returned by the
99 query in QUERY-EXPRESSION. The results of the function are
100 collected as specified in OUTPUT-TYPE-SPEC and returned like in
102 (if (listp query-expression)
104 (map output-type-spec #'(lambda (x) (apply function x)) query-expression)
106 (macrolet ((type-specifier-atom (type)
107 `(if (atom ,type) ,type (car ,type))))
108 (case (type-specifier-atom output-type-spec)
110 (map-query-for-effect function query-expression database
113 (map-query-to-list function query-expression database result-types))
114 ((simple-vector simple-string vector string array simple-array
115 bit-vector simple-bit-vector base-string
117 (map-query-to-simple output-type-spec function query-expression
118 database result-types))
121 (cmucl-compat:result-type-or-lose output-type-spec t)
122 function query-expression :database database
123 :result-types result-types))))))
125 (defun map-query-for-effect (function query-expression database result-types)
126 (multiple-value-bind (result-set columns)
127 (database-query-result-set query-expression database :full-set nil
128 :result-types result-types)
131 (do ((row (make-list columns)))
132 ((not (database-store-next-row result-set database row))
134 (apply function row))
135 (database-dump-result-set result-set database)))))
137 (defun map-query-to-list (function query-expression database result-types)
138 (multiple-value-bind (result-set columns)
139 (database-query-result-set query-expression database :full-set nil
140 :result-types result-types)
143 (let ((result (list nil)))
144 (do ((row (make-list columns))
145 (current-cons result (cdr current-cons)))
146 ((not (database-store-next-row result-set database row))
148 (rplacd current-cons (list (apply function row)))))
149 (database-dump-result-set result-set database)))))
152 (defun map-query-to-simple (output-type-spec function query-expression database result-types)
153 (multiple-value-bind (result-set columns rows)
154 (database-query-result-set query-expression database :full-set t
155 :result-types result-types)
159 ;; We know the row count in advance, so we allocate once
161 (cmucl-compat:make-sequence-of-type output-type-spec rows))
162 (row (make-list columns))
163 (index 0 (1+ index)))
164 ((not (database-store-next-row result-set database row))
166 (declare (fixnum index))
167 (setf (aref result index)
168 (apply function row)))
169 ;; Database can't report row count in advance, so we have
170 ;; to grow and shrink our vector dynamically
172 (cmucl-compat:make-sequence-of-type output-type-spec 100))
173 (allocated-length 100)
174 (row (make-list columns))
175 (index 0 (1+ index)))
176 ((not (database-store-next-row result-set database row))
177 (cmucl-compat:shrink-vector result index))
178 (declare (fixnum allocated-length index))
179 (when (>= index allocated-length)
180 (setq allocated-length (* allocated-length 2)
181 result (adjust-array result allocated-length)))
182 (setf (aref result index)
183 (apply function row))))
184 (database-dump-result-set result-set database)))))
186 ;;; Large objects support
188 (defun create-large-object (&key (database *default-database*))
189 "Creates a new large object in the database and returns the object identifier"
190 (database-create-large-object database))
192 (defun write-large-object (object-id data &key (database *default-database*))
193 "Writes data to the large object"
194 (database-write-large-object object-id data database))
196 (defun read-large-object (object-id &key (database *default-database*))
197 "Reads the large object content"
198 (database-read-large-object object-id database))
200 (defun delete-large-object (object-id &key (database *default-database*))
201 "Deletes the large object in the database"
202 (database-delete-large-object object-id database))