1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: High-level SQL interface
7 ;;;; Authors: Kevin M. Rosenberg based on code by Pierre R. Mai
8 ;;;; Date Started: Feb 2002
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
13 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
15 ;;;; CLSQL users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
18 ;;;; *************************************************************************
20 (eval-when (:compile-toplevel)
21 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))))
23 (in-package #:clsql-sys)
28 (defvar *connect-if-exists* :error
29 "Default value for the if-exists parameter of connect calls.")
31 (defvar *connected-databases* nil
32 "List of active database objects.")
34 (defun connected-databases ()
35 "Return the list of active database objects."
36 *connected-databases*)
38 (defvar *default-database* nil
39 "Specifies the default database to be used.")
41 (defun find-database (database &optional (errorp t))
44 ;; Return the database object itself
47 (or (find database (connected-databases)
53 :format-control "There exists no database called ~A."
54 :format-arguments (list database)))))))
56 (defun connect (connection-spec
57 &key (if-exists *connect-if-exists*)
58 (database-type *default-database-type*)
60 "Connects to a database of the given database-type, using the type-specific
62 If pool is t the connection will be taken from the general pool,
63 if pool is a conn-pool object the connection will be taken from this pool.
66 (acquire-from-pool connection-spec database-type pool)
67 (let* ((db-name (database-name-from-spec connection-spec database-type))
68 (old-db (unless (eq if-exists :new) (find-database db-name nil)))
74 ; (database-connect connection-spec database-type)))
77 (database-connect connection-spec database-type))
78 (warn 'clsql-exists-warning :old-db old-db :new-db result))
81 (error 'clsql-exists-error :old-db old-db)
83 :report "Create a new connection."
85 (database-connect connection-spec database-type)))
87 :report "Use the existing connection."
88 (setq result old-db))))
91 (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
93 (setq result old-db)))
95 (database-connect connection-spec database-type)))
97 (pushnew result *connected-databases*)
98 (setq *default-database* result)
102 (defun disconnect (&key (database *default-database*))
103 "Closes the connection to database. Resets *default-database* if that
104 database was disconnected and only one other connection exists.
105 if the database is from a pool it will be released to this pool."
106 (if (conn-pool database)
107 (release-to-pool database)
108 (when (database-disconnect database)
109 (setq *connected-databases* (delete database *connected-databases*))
110 (when (eq database *default-database*)
111 (setq *default-database* (car *connected-databases*)))
112 (change-class database 'closed-database)
115 ;;; Basic operations on databases
117 (defgeneric query (expression &key database types))
118 (defmethod query (query-expression &key (database *default-database*)
120 "Execute the SQL query expression query-expression on the given database.
121 Returns a list of lists of values of the result of that expression."
122 (database-query query-expression database types))
125 (defgeneric execute-command (expression &key database))
126 (defmethod execute-command (sql-expression &key (database *default-database*))
127 "Execute the SQL command expression sql-expression on the given database.
128 Returns true on success or nil on failure."
129 (database-execute-command sql-expression database))
133 (defun map-query (output-type-spec function query-expression
134 &key (database *default-database*)
136 "Map the function over all tuples that are returned by the query in
137 query-expression. The results of the function are collected as
138 specified in output-type-spec and returned like in MAP."
139 ;; DANGER Will Robinson: Parts of the code for implementing
140 ;; map-query (including the code below and the helper functions
141 ;; called) are highly CMU CL specific.
142 ;; KMR -- these have been replaced with cross-platform instructions above
143 (macrolet ((type-specifier-atom (type)
144 `(if (atom ,type) ,type (car ,type))))
145 (case (type-specifier-atom output-type-spec)
147 (map-query-for-effect function query-expression database types))
149 (map-query-to-list function query-expression database types))
150 ((simple-vector simple-string vector string array simple-array
151 bit-vector simple-bit-vector base-string
153 (map-query-to-simple output-type-spec function query-expression database types))
155 (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
156 function query-expression :database database :types types)))))
158 (defun map-query-for-effect (function query-expression database types)
159 (multiple-value-bind (result-set columns)
160 (database-query-result-set query-expression database :full-set nil
164 (do ((row (make-list columns)))
165 ((not (database-store-next-row result-set database row))
167 (apply function row))
168 (database-dump-result-set result-set database)))))
170 (defun map-query-to-list (function query-expression database types)
171 (multiple-value-bind (result-set columns)
172 (database-query-result-set query-expression database :full-set nil
176 (let ((result (list nil)))
177 (do ((row (make-list columns))
178 (current-cons result (cdr current-cons)))
179 ((not (database-store-next-row result-set database row))
181 (rplacd current-cons (list (apply function row)))))
182 (database-dump-result-set result-set database)))))
185 (defun map-query-to-simple (output-type-spec function query-expression database types)
186 (multiple-value-bind (result-set columns rows)
187 (database-query-result-set query-expression database :full-set t
192 ;; We know the row count in advance, so we allocate once
194 (cmucl-compat:make-sequence-of-type output-type-spec rows))
195 (row (make-list columns))
196 (index 0 (1+ index)))
197 ((not (database-store-next-row result-set database row))
199 (declare (fixnum index))
200 (setf (aref result index)
201 (apply function row)))
202 ;; Database can't report row count in advance, so we have
203 ;; to grow and shrink our vector dynamically
205 (cmucl-compat:make-sequence-of-type output-type-spec 100))
206 (allocated-length 100)
207 (row (make-list columns))
208 (index 0 (1+ index)))
209 ((not (database-store-next-row result-set database row))
210 (cmucl-compat:shrink-vector result index))
211 (declare (fixnum allocated-length index))
212 (when (>= index allocated-length)
213 (setq allocated-length (* allocated-length 2)
214 result (adjust-array result allocated-length)))
215 (setf (aref result index)
216 (apply function row))))
217 (database-dump-result-set result-set database)))))
219 (defmacro do-query (((&rest args) query-expression
220 &key (database '*default-database*)
223 (let ((result-set (gensym))
227 `(let ((,db ,database))
228 (multiple-value-bind (,result-set ,columns)
229 (database-query-result-set ,query-expression ,db
230 :full-set nil :types ,types)
233 (do ((,row (make-list ,columns)))
234 ((not (database-store-next-row ,result-set ,db ,row))
236 (destructuring-bind ,args ,row
238 (database-dump-result-set ,result-set ,db)))))))
240 ;;; Marc Battyani : Large objects support
242 (defun create-large-object (&key (database *default-database*))
243 "Creates a new large object in the database and returns the object identifier"
244 (database-create-large-object database))
246 (defun write-large-object (object-id data &key (database *default-database*))
247 "Writes data to the large object"
248 (database-write-large-object object-id data database))
250 (defun read-large-object (object-id &key (database *default-database*))
251 "Reads the large object content"
252 (database-read-large-object object-id database))
254 (defun delete-large-object (object-id &key (database *default-database*))
255 "Deletes the large object in the database"
256 (database-delete-large-object object-id database))
259 ;;; Row processing macro
263 (defun lisp->sql-name (field)
266 (symbol (string-upcase (symbol-name field)))
268 (t (format nil "~A" field))))
270 (defun field-names (field-forms)
271 "Return a list of field name strings from a fields form"
272 (loop for field-form in field-forms
275 (if (cadr field-form)
279 (defun from-names (from)
280 "Return a list of field name strings from a fields form"
281 (loop for table in (if (atom from) (list from) from)
282 collect (lisp->sql-name table)))
285 (defun where-strings (where)
286 (loop for w in (if (atom (car where)) (list where) where)
289 (format nil "~A ~A ~A" (second w) (first w) (third w))
290 (format nil "~A" w))))
292 (defun order-by-strings (order-by)
293 (loop for o in order-by
297 (format nil "~A ~A" (lisp->sql-name (car o))
298 (lisp->sql-name (cadr o))))))
300 (defun query-string (fields from where distinct order-by limit)
303 (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}"
304 (if distinct "distinct " "") (field-names fields)
306 (if where (format nil " where ~{~A~^ ~}"
307 (where-strings where)) "")
308 (if order-by (format nil " order by ~{~A~^, ~}"
309 (order-by-strings order-by)))
310 (if limit (format nil " limit ~D" limit) "")))
312 (defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body)
313 (let ((d (gensym "DISTINCT-"))
314 (bind-fields (loop for f in fields collect (car f)))
315 (w (gensym "WHERE-"))
316 (o (gensym "ORDER-BY-"))
317 (frm (gensym "FROM-"))
318 (l (gensym "LIMIT-"))
319 (q (gensym "QUERY-")))
325 (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l)))
326 (loop for tuple in (query ,q)
327 collect (destructuring-bind ,bind-fields tuple