1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: High-level SQL interface
7 ;;;; Programmers: Kevin M. Rosenberg based on
8 ;;;; Original code by Pierre R. Mai
9 ;;;; Date Started: Feb 2002
11 ;;;; $Id: sql.cl,v 1.5 2002/03/24 22:25:51 kevin Exp $
13 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
16 ;;;; CLSQL users are granted the rights to distribute and use this software
17 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
18 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
19 ;;;; *************************************************************************
21 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
22 (in-package :clsql-sys)
24 ;;;; Modified to use CMUCL-COMPAT library and to fix format strings in
27 ;;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
30 (define-condition clsql-condition ()
33 (define-condition clsql-error (error clsql-condition)
36 (define-condition clsql-simple-error (simple-condition clsql-error)
39 (define-condition clsql-warning (warning clsql-condition)
42 (define-condition clsql-simple-warning (simple-condition clsql-warning)
45 (define-condition clsql-invalid-spec-error (clsql-error)
46 ((connection-spec :initarg :connection-spec
47 :reader clsql-invalid-spec-error-connection-spec)
48 (database-type :initarg :database-type
49 :reader clsql-invalid-spec-error-database-type)
50 (template :initarg :template
51 :reader clsql-invalid-spec-error-template))
52 (:report (lambda (c stream)
53 (format stream "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
54 (clsql-invalid-spec-error-connection-spec c)
55 (clsql-invalid-spec-error-database-type c)
56 (clsql-invalid-spec-error-template c)))))
58 (defmacro check-connection-spec (connection-spec database-type template)
59 "Check the connection specification against the provided template,
60 and signal an clsql-invalid-spec-error if they don't match."
62 (destructuring-bind ,template ,connection-spec
63 (declare (ignore ,@template))
65 (error () (error 'clsql-invalid-spec-error
66 :connection-spec ,connection-spec
67 :database-type ,database-type
68 :template (quote ,template)))))
70 (define-condition clsql-connect-error (clsql-error)
71 ((database-type :initarg :database-type
72 :reader clsql-connect-error-database-type)
73 (connection-spec :initarg :connection-spec
74 :reader clsql-connect-error-connection-spec)
75 (errno :initarg :errno :reader clsql-connect-error-errno)
76 (error :initarg :error :reader clsql-connect-error-error))
77 (:report (lambda (c stream)
78 (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred."
79 (database-name-from-spec
80 (clsql-connect-error-connection-spec c)
81 (clsql-connect-error-database-type c))
82 (clsql-connect-error-database-type c)
83 (clsql-connect-error-errno c)
84 (clsql-connect-error-error c)))))
86 (define-condition clsql-sql-error (clsql-error)
87 ((database :initarg :database :reader clsql-sql-error-database)
88 (expression :initarg :expression :reader clsql-sql-error-expression)
89 (errno :initarg :errno :reader clsql-sql-error-errno)
90 (error :initarg :error :reader clsql-sql-error-error))
91 (:report (lambda (c stream)
92 (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred."
93 (clsql-sql-error-database c)
94 (clsql-sql-error-expression c)
95 (clsql-sql-error-errno c)
96 (clsql-sql-error-error c)))))
98 (define-condition clsql-database-warning (clsql-warning)
99 ((database :initarg :database :reader clsql-database-warning-database)
100 (message :initarg :message :reader clsql-database-warning-message))
101 (:report (lambda (c stream)
102 (format stream "While accessing database ~A~% Warning: ~A~% has occurred."
103 (clsql-database-warning-database c)
104 (clsql-database-warning-message c)))))
106 (define-condition clsql-exists-condition (clsql-condition)
107 ((old-db :initarg :old-db :reader clsql-exists-condition-old-db)
108 (new-db :initarg :new-db :reader clsql-exists-condition-new-db
110 (:report (lambda (c stream)
111 (format stream "In call to ~S:~%" 'connect)
113 ((null (clsql-exists-condition-new-db c))
115 " There is an existing connection ~A to database ~A."
116 (clsql-exists-condition-old-db c)
117 (database-name (clsql-exists-condition-old-db c))))
118 ((eq (clsql-exists-condition-new-db c)
119 (clsql-exists-condition-old-db c))
121 " Using existing connection ~A to database ~A."
122 (clsql-exists-condition-old-db c)
123 (database-name (clsql-exists-condition-old-db c))))
126 " Created new connection ~A to database ~A~% ~
127 although there is an existing connection (~A)."
128 (clsql-exists-condition-new-db c)
129 (database-name (clsql-exists-condition-new-db c))
130 (clsql-exists-condition-old-db c)))))))
132 (define-condition clsql-exists-warning (clsql-exists-condition
136 (define-condition clsql-exists-error (clsql-exists-condition
140 (define-condition clsql-closed-error (clsql-error)
141 ((database :initarg :database :reader clsql-closed-error-database))
142 (:report (lambda (c stream)
143 (format stream "The database ~A has already been closed."
144 (clsql-closed-error-database c)))))
148 (defvar *loaded-database-types* nil
149 "Contains a list of database types which have been defined/loaded.")
151 (defun reload-database-types ()
152 "Reloads any foreign code for the loaded database types after a dump."
153 (mapc #'database-type-load-foreign *loaded-database-types*))
155 (defgeneric database-type-load-foreign (database-type)
157 "The internal generic implementation of reload-database-types.")
158 (:method :after (database-type)
159 (pushnew database-type *loaded-database-types*)))
161 (defgeneric database-type-library-loaded (database-type)
163 "The internal generic implementation for checking if
164 database type library loaded successfully."))
166 (defvar *default-database-type* nil
167 "Specifies the default type of database. Currently only :mysql is
170 (defvar *initialized-database-types* nil
171 "Contains a list of database types which have been initialized by calls
172 to initialize-database-type.")
174 (defun initialize-database-type (&key (database-type *default-database-type*))
175 "Initialize the given database-type, if it is not already
176 initialized, as indicated by `*initialized-database-types*'."
177 (if (member database-type *initialized-database-types*)
179 (when (database-initialize-database-type database-type)
180 (push database-type *initialized-database-types*)
183 (defgeneric database-initialize-database-type (database-type)
185 "The internal generic implementation of initialize-database-type."))
187 ;;; Database handling
189 (defvar *connect-if-exists* :error
190 "Default value for the if-exists parameter of connect calls.")
192 (defvar *connected-databases* nil
193 "List of active database objects.")
195 (defun connected-databases ()
196 "Return the list of active database objects."
197 *connected-databases*)
199 (defvar *default-database* nil
200 "Specifies the default database to be used.")
202 (defclass database ()
203 ((name :initarg :name :reader database-name))
205 "This class is the supertype of all databases handled by CLSQL."))
207 (defmethod print-object ((object database) stream)
208 (print-unreadable-object (object stream :type t :identity t)
209 (write-string (if (slot-boundp object 'name)
210 (database-name object)
214 (defclass closed-database ()
215 ((name :initarg :name :reader database-name))
217 "This class represents all databases after they are closed via
220 (defmethod print-object ((object closed-database) stream)
221 (print-unreadable-object (object stream :type t :identity t)
222 (write-string (if (slot-boundp object 'name)
223 (database-name object)
227 (defun signal-closed-database-error (database)
228 (cerror "Ignore this error and return nil."
232 (defun find-database (database &optional (errorp t))
235 ;; Return the database object itself
238 (or (find database (connected-databases)
242 (cerror "Return nil."
244 :format-control "There exists no database called ~A."
245 :format-arguments (list database)))))))
247 (defun connect (connection-spec
248 &key (if-exists *connect-if-exists*)
249 (database-type *default-database-type*))
250 "Connects to a database of the given database-type, using the type-specific
251 connection-spec. if-exists is currently ignored."
252 (let* ((db-name (database-name-from-spec connection-spec database-type))
253 (old-db (find-database db-name nil))
259 (database-connect connection-spec database-type)))
262 (database-connect connection-spec database-type))
263 (warn 'clsql-exists-warning :old-db old-db :new-db result))
266 (error 'clsql-exists-error :old-db old-db)
268 :report "Create a new connection."
270 (database-connect connection-spec database-type)))
272 :report "Use the existing connection."
273 (setq result old-db))))
276 (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
278 (setq result old-db)))
280 (database-connect connection-spec database-type)))
282 (pushnew result *connected-databases*)
283 (setq *default-database* result)
286 (defgeneric database-name-from-spec (connection-spec database-type)
288 "Returns the name of the database that would be created if connect
289 was called with the connection-spec."))
291 (defgeneric database-connect (connection-spec database-type)
292 (:documentation "Internal generic implementation of connect."))
294 (defun disconnect (&key (database *default-database*))
295 "Closes the connection to database. Resets *default-database* if that
296 database was disconnected and only one other connection exists."
297 (when (database-disconnect database)
298 (setq *connected-databases* (delete database *connected-databases*))
299 (when (eq database *default-database*)
300 (setq *default-database* (car *connected-databases*)))
301 (change-class database 'closed-database)
304 (defgeneric database-disconnect (database)
305 (:method ((database closed-database))
306 (signal-closed-database-error database))
307 (:documentation "Internal generic implementation of disconnect."))
309 ;;; Basic operations on databases
311 (defmethod query (query-expression &key (database *default-database*)
313 "Execute the SQL query expression query-expression on the given database.
314 Returns a list of lists of values of the result of that expression."
315 (database-query query-expression database field-types))
317 (defgeneric database-query (query-expression database field-types)
318 (:method (query-expression (database closed-database) field-types)
319 (declare (ignore query-expression field-types))
320 (signal-closed-database-error database))
321 (:documentation "Internal generic implementation of query."))
323 (defmethod execute-command (sql-expression &key (database *default-database*))
324 "Execute the SQL command expression sql-expression on the given database.
325 Returns true on success or nil on failure."
326 (database-execute-command sql-expression database))
328 (defgeneric database-execute-command (sql-expression database)
329 (:method (sql-expression (database closed-database))
330 (declare (ignore sql-expression))
331 (signal-closed-database-error database))
332 (:documentation "Internal generic implementation of execute-command."))
334 ;;; Mapping and iteration
335 (defgeneric database-query-result-set
336 (query-expression database &key full-set field-types)
337 (:method (query-expression (database closed-database) &key full-set field-types)
338 (declare (ignore query-expression full-set field-types))
339 (signal-closed-database-error database)
340 (values nil nil nil))
342 "Internal generic implementation of query mapping. Starts the
343 query specified by query-expression on the given database and returns
344 a result-set to be used with database-store-next-row and
345 database-dump-result-set to access the returned data. The second
346 value is the number of columns in the result-set, if there are any.
347 If full-set is true, the number of rows in the result-set is returned
348 as a third value, if this is possible (otherwise nil is returned for
349 the third value). This might have memory and resource usage
350 implications, since many databases will require the query to be
351 executed in full to answer this question. If the query produced no
352 results then nil is returned for all values that would have been
353 returned otherwise. If an error occurs during query execution, the
354 function should signal a clsql-sql-error."))
356 (defgeneric database-dump-result-set (result-set database)
357 (:method (result-set (database closed-database))
358 (declare (ignore result-set))
359 (signal-closed-database-error database))
360 (:documentation "Dumps the received result-set."))
362 (defgeneric database-store-next-row (result-set database list)
363 (:method (result-set (database closed-database) list)
364 (declare (ignore result-set list))
365 (signal-closed-database-error database))
367 "Returns t and stores the next row in the result set in list or
368 returns nil when result-set is finished."))
372 (defun map-query (output-type-spec function query-expression
373 &key (database *default-database*)
375 "Map the function over all tuples that are returned by the query in
376 query-expression. The results of the function are collected as
377 specified in output-type-spec and returned like in MAP."
378 ;; DANGER Will Robinson: Parts of the code for implementing
379 ;; map-query (including the code below and the helper functions
380 ;; called) are highly CMU CL specific.
381 ;; KMR -- these have been replaced with cross-platform instructions above
382 (macrolet ((type-specifier-atom (type)
383 `(if (atom ,type) ,type (car ,type))))
384 (case (type-specifier-atom output-type-spec)
386 (map-query-for-effect function query-expression database field-types))
388 (map-query-to-list function query-expression database field-types))
389 ((simple-vector simple-string vector string array simple-array
390 bit-vector simple-bit-vector base-string
392 (map-query-to-simple output-type-spec function query-expression database field-types))
394 (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
395 function query-expression :database database :field-types field-types)))))
397 (defun map-query-for-effect (function query-expression database field-types)
398 (multiple-value-bind (result-set columns)
399 (database-query-result-set query-expression database :full-set nil
400 :field-types field-types)
403 (do ((row (make-list columns)))
404 ((not (database-store-next-row result-set database row))
406 (apply function row))
407 (database-dump-result-set result-set database)))))
409 (defun map-query-to-list (function query-expression database field-types)
410 (multiple-value-bind (result-set columns)
411 (database-query-result-set query-expression database :full-set nil
412 :field-types field-types)
415 (let ((result (list nil)))
416 (do ((row (make-list columns))
417 (current-cons result (cdr current-cons)))
418 ((not (database-store-next-row result-set database row))
420 (rplacd current-cons (list (apply function row)))))
421 (database-dump-result-set result-set database)))))
424 (defun map-query-to-simple (output-type-spec function query-expression database field-types)
425 (multiple-value-bind (result-set columns rows)
426 (database-query-result-set query-expression database :full-set t
427 :field-types field-types)
431 ;; We know the row count in advance, so we allocate once
433 (cmucl-compat:make-sequence-of-type output-type-spec rows))
434 (row (make-list columns))
435 (index 0 (1+ index)))
436 ((not (database-store-next-row result-set database row))
438 (declare (fixnum index))
439 (setf (aref result index)
440 (apply function row)))
441 ;; Database can't report row count in advance, so we have
442 ;; to grow and shrink our vector dynamically
444 (cmucl-compat:make-sequence-of-type output-type-spec 100))
445 (allocated-length 100)
446 (row (make-list columns))
447 (index 0 (1+ index)))
448 ((not (database-store-next-row result-set database row))
449 (cmucl-compat:shrink-vector result index))
450 (declare (fixnum allocated-length index))
451 (when (>= index allocated-length)
452 (setq allocated-length (* allocated-length 2)
453 result (adjust-array result allocated-length)))
454 (setf (aref result index)
455 (apply function row))))
456 (database-dump-result-set result-set database)))))
458 (defmacro do-query (((&rest args) query-expression
459 &key (database '*default-database*)
462 (let ((result-set (gensym))
466 `(let ((,db ,database))
467 (multiple-value-bind (,result-set ,columns)
468 (database-query-result-set ,query-expression ,db
469 :full-set nil :field-types ,field-types)
472 (do ((,row (make-list ,columns)))
473 ((not (database-store-next-row ,result-set ,db ,row))
475 (destructuring-bind ,args ,row
477 (database-dump-result-set ,result-set ,db)))))))