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-sys)
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 nil) (flatp nil))
34 (record-sql-command query-expression database)
35 (let* ((res (database-query query-expression database result-types))
36 (res (if (and flatp (= (length
37 (slot-value query-expression 'selections))
41 (record-sql-result res database)
46 (defgeneric execute-command (expression &key database)
48 "Executes the SQL command specified by EXPRESSION for the database
49 specified by DATABASE, which has a default value of
50 *DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement
51 other than a query. To run a stored procedure, pass an appropriate
52 string. The call to the procedure needs to be wrapped in a BEGIN END
55 (defmethod execute-command ((sql-expression string)
56 &key (database *default-database*))
57 (record-sql-command sql-expression database)
58 (let ((res (database-execute-command sql-expression database)))
59 (record-sql-result res 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 attributes
67 of each record resulting from QUERY. The return value is determined by
68 the result of executing BODY. The default value of DATABASE is
70 (let ((result-set (gensym))
74 `(let ((,db ,database))
75 (multiple-value-bind (,result-set ,columns)
76 (database-query-result-set ,query-expression ,db
77 :full-set nil :result-types ,result-types)
80 (do ((,row (make-list ,columns)))
81 ((not (database-store-next-row ,result-set ,db ,row))
83 (destructuring-bind ,args ,row
85 (database-dump-result-set ,result-set ,db)))))))
87 (defun map-query (output-type-spec function query-expression
88 &key (database *default-database*)
90 "Map the function over all tuples that are returned by the query in
91 query-expression. The results of the function are collected as
92 specified in output-type-spec and returned like in MAP."
93 (macrolet ((type-specifier-atom (type)
94 `(if (atom ,type) ,type (car ,type))))
95 (case (type-specifier-atom output-type-spec)
97 (map-query-for-effect function query-expression database result-types))
99 (map-query-to-list function query-expression database result-types))
100 ((simple-vector simple-string vector string array simple-array
101 bit-vector simple-bit-vector base-string
103 (map-query-to-simple output-type-spec function query-expression database result-types))
105 (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
106 function query-expression :database database :result-types result-types)))))
108 (defun map-query-for-effect (function query-expression database result-types)
109 (multiple-value-bind (result-set columns)
110 (database-query-result-set query-expression database :full-set nil
111 :result-types result-types)
114 (do ((row (make-list columns)))
115 ((not (database-store-next-row result-set database row))
117 (apply function row))
118 (database-dump-result-set result-set database)))))
120 (defun map-query-to-list (function query-expression database result-types)
121 (multiple-value-bind (result-set columns)
122 (database-query-result-set query-expression database :full-set nil
123 :result-types result-types)
126 (let ((result (list nil)))
127 (do ((row (make-list columns))
128 (current-cons result (cdr current-cons)))
129 ((not (database-store-next-row result-set database row))
131 (rplacd current-cons (list (apply function row)))))
132 (database-dump-result-set result-set database)))))
135 (defun map-query-to-simple (output-type-spec function query-expression database result-types)
136 (multiple-value-bind (result-set columns rows)
137 (database-query-result-set query-expression database :full-set t
138 :result-types result-types)
142 ;; We know the row count in advance, so we allocate once
144 (cmucl-compat:make-sequence-of-type output-type-spec rows))
145 (row (make-list columns))
146 (index 0 (1+ index)))
147 ((not (database-store-next-row result-set database row))
149 (declare (fixnum index))
150 (setf (aref result index)
151 (apply function row)))
152 ;; Database can't report row count in advance, so we have
153 ;; to grow and shrink our vector dynamically
155 (cmucl-compat:make-sequence-of-type output-type-spec 100))
156 (allocated-length 100)
157 (row (make-list columns))
158 (index 0 (1+ index)))
159 ((not (database-store-next-row result-set database row))
160 (cmucl-compat:shrink-vector result index))
161 (declare (fixnum allocated-length index))
162 (when (>= index allocated-length)
163 (setq allocated-length (* allocated-length 2)
164 result (adjust-array result allocated-length)))
165 (setf (aref result index)
166 (apply function row))))
167 (database-dump-result-set result-set database)))))