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.8 2002/03/29 07:42:10 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)
25 ;;; - to use CMUCL-COMPAT library
26 ;;; - fix format strings in error messages
30 ;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
35 (defvar *loaded-database-types* nil
36 "Contains a list of database types which have been defined/loaded.")
38 (defun reload-database-types ()
39 "Reloads any foreign code for the loaded database types after a dump."
40 (mapc #'database-type-load-foreign *loaded-database-types*))
43 (defvar *default-database-type* nil
44 "Specifies the default type of database. Currently only :mysql is
47 (defvar *initialized-database-types* nil
48 "Contains a list of database types which have been initialized by calls
49 to initialize-database-type.")
51 (defun initialize-database-type (&key (database-type *default-database-type*))
52 "Initialize the given database-type, if it is not already
53 initialized, as indicated by `*initialized-database-types*'."
54 (if (member database-type *initialized-database-types*)
56 (when (database-initialize-database-type database-type)
57 (push database-type *initialized-database-types*)
63 (defvar *connect-if-exists* :error
64 "Default value for the if-exists parameter of connect calls.")
66 (defvar *connected-databases* nil
67 "List of active database objects.")
69 (defun connected-databases ()
70 "Return the list of active database objects."
71 *connected-databases*)
73 (defvar *default-database* nil
74 "Specifies the default database to be used.")
77 ((name :initarg :name :reader database-name))
79 "This class is the supertype of all databases handled by CLSQL."))
81 (defmethod print-object ((object database) stream)
82 (print-unreadable-object (object stream :type t :identity t)
83 (write-string (if (slot-boundp object 'name)
84 (database-name object)
88 (defclass closed-database ()
89 ((name :initarg :name :reader database-name))
91 "This class represents all databases after they are closed via
94 (defmethod print-object ((object closed-database) stream)
95 (print-unreadable-object (object stream :type t :identity t)
96 (write-string (if (slot-boundp object 'name)
97 (database-name object)
101 (defun signal-closed-database-error (database)
102 (cerror "Ignore this error and return nil."
106 (defun find-database (database &optional (errorp t))
109 ;; Return the database object itself
112 (or (find database (connected-databases)
116 (cerror "Return nil."
118 :format-control "There exists no database called ~A."
119 :format-arguments (list database)))))))
121 (defun connect (connection-spec
122 &key (if-exists *connect-if-exists*)
123 (database-type *default-database-type*))
124 "Connects to a database of the given database-type, using the type-specific
125 connection-spec. if-exists is currently ignored."
126 (let* ((db-name (database-name-from-spec connection-spec database-type))
127 (old-db (find-database db-name nil))
133 (database-connect connection-spec database-type)))
136 (database-connect connection-spec database-type))
137 (warn 'clsql-exists-warning :old-db old-db :new-db result))
140 (error 'clsql-exists-error :old-db old-db)
142 :report "Create a new connection."
144 (database-connect connection-spec database-type)))
146 :report "Use the existing connection."
147 (setq result old-db))))
150 (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
152 (setq result old-db)))
154 (database-connect connection-spec database-type)))
156 (pushnew result *connected-databases*)
157 (setq *default-database* result)
162 (defun disconnect (&key (database *default-database*))
163 "Closes the connection to database. Resets *default-database* if that
164 database was disconnected and only one other connection exists."
165 (when (database-disconnect database)
166 (setq *connected-databases* (delete database *connected-databases*))
167 (when (eq database *default-database*)
168 (setq *default-database* (car *connected-databases*)))
169 (change-class database 'closed-database)
174 ;;; Basic operations on databases
176 (defmethod query (query-expression &key (database *default-database*)
178 "Execute the SQL query expression query-expression on the given database.
179 Returns a list of lists of values of the result of that expression."
180 (database-query query-expression database types))
184 (defmethod execute-command (sql-expression &key (database *default-database*))
185 "Execute the SQL command expression sql-expression on the given database.
186 Returns true on success or nil on failure."
187 (database-execute-command sql-expression database))
191 (defun map-query (output-type-spec function query-expression
192 &key (database *default-database*)
194 "Map the function over all tuples that are returned by the query in
195 query-expression. The results of the function are collected as
196 specified in output-type-spec and returned like in MAP."
197 ;; DANGER Will Robinson: Parts of the code for implementing
198 ;; map-query (including the code below and the helper functions
199 ;; called) are highly CMU CL specific.
200 ;; KMR -- these have been replaced with cross-platform instructions above
201 (macrolet ((type-specifier-atom (type)
202 `(if (atom ,type) ,type (car ,type))))
203 (case (type-specifier-atom output-type-spec)
205 (map-query-for-effect function query-expression database types))
207 (map-query-to-list function query-expression database types))
208 ((simple-vector simple-string vector string array simple-array
209 bit-vector simple-bit-vector base-string
211 (map-query-to-simple output-type-spec function query-expression database types))
213 (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
214 function query-expression :database database :types types)))))
216 (defun map-query-for-effect (function query-expression database types)
217 (multiple-value-bind (result-set columns)
218 (database-query-result-set query-expression database :full-set nil
222 (do ((row (make-list columns)))
223 ((not (database-store-next-row result-set database row))
225 (apply function row))
226 (database-dump-result-set result-set database)))))
228 (defun map-query-to-list (function query-expression database types)
229 (multiple-value-bind (result-set columns)
230 (database-query-result-set query-expression database :full-set nil
234 (let ((result (list nil)))
235 (do ((row (make-list columns))
236 (current-cons result (cdr current-cons)))
237 ((not (database-store-next-row result-set database row))
239 (rplacd current-cons (list (apply function row)))))
240 (database-dump-result-set result-set database)))))
243 (defun map-query-to-simple (output-type-spec function query-expression database types)
244 (multiple-value-bind (result-set columns rows)
245 (database-query-result-set query-expression database :full-set t
250 ;; We know the row count in advance, so we allocate once
252 (cmucl-compat:make-sequence-of-type output-type-spec rows))
253 (row (make-list columns))
254 (index 0 (1+ index)))
255 ((not (database-store-next-row result-set database row))
257 (declare (fixnum index))
258 (setf (aref result index)
259 (apply function row)))
260 ;; Database can't report row count in advance, so we have
261 ;; to grow and shrink our vector dynamically
263 (cmucl-compat:make-sequence-of-type output-type-spec 100))
264 (allocated-length 100)
265 (row (make-list columns))
266 (index 0 (1+ index)))
267 ((not (database-store-next-row result-set database row))
268 (cmucl-compat:shrink-vector result index))
269 (declare (fixnum allocated-length index))
270 (when (>= index allocated-length)
271 (setq allocated-length (* allocated-length 2)
272 result (adjust-array result allocated-length)))
273 (setf (aref result index)
274 (apply function row))))
275 (database-dump-result-set result-set database)))))
277 (defmacro do-query (((&rest args) query-expression
278 &key (database '*default-database*)
281 (let ((result-set (gensym))
285 `(let ((,db ,database))
286 (multiple-value-bind (,result-set ,columns)
287 (database-query-result-set ,query-expression ,db
288 :full-set nil :types ,types)
291 (do ((,row (make-list ,columns)))
292 ((not (database-store-next-row ,result-set ,db ,row))
294 (destructuring-bind ,args ,row
296 (database-dump-result-set ,result-set ,db)))))))