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.11 2002/03/29 08:34:44 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 (defmethod database-type-load-foreign :after (database-type)
39 (when (database-type-library-loaded database-type)
40 (pushnew database-type *loaded-database-types*)))
42 (defun reload-database-types ()
43 "Reloads any foreign code for the loaded database types after a dump."
44 (mapc #'database-type-load-foreign *loaded-database-types*))
46 (defvar *default-database-type* nil
47 "Specifies the default type of database. Currently only :mysql is
50 (defvar *initialized-database-types* nil
51 "Contains a list of database types which have been initialized by calls
52 to initialize-database-type.")
54 (defun initialize-database-type (&key (database-type *default-database-type*))
55 "Initialize the given database-type, if it is not already
56 initialized, as indicated by `*initialized-database-types*'."
57 (if (member database-type *initialized-database-types*)
59 (when (database-initialize-database-type database-type)
60 (push database-type *initialized-database-types*)
66 (defvar *connect-if-exists* :error
67 "Default value for the if-exists parameter of connect calls.")
69 (defvar *connected-databases* nil
70 "List of active database objects.")
72 (defun connected-databases ()
73 "Return the list of active database objects."
74 *connected-databases*)
76 (defvar *default-database* nil
77 "Specifies the default database to be used.")
81 (defun find-database (database &optional (errorp t))
84 ;; Return the database object itself
87 (or (find database (connected-databases)
93 :format-control "There exists no database called ~A."
94 :format-arguments (list database)))))))
96 (defun connect (connection-spec
97 &key (if-exists *connect-if-exists*)
98 (database-type *default-database-type*))
99 "Connects to a database of the given database-type, using the type-specific
100 connection-spec. if-exists is currently ignored."
101 (let* ((db-name (database-name-from-spec connection-spec database-type))
102 (old-db (find-database db-name nil))
108 (database-connect connection-spec database-type)))
111 (database-connect connection-spec database-type))
112 (warn 'clsql-exists-warning :old-db old-db :new-db result))
115 (error 'clsql-exists-error :old-db old-db)
117 :report "Create a new connection."
119 (database-connect connection-spec database-type)))
121 :report "Use the existing connection."
122 (setq result old-db))))
125 (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
127 (setq result old-db)))
129 (database-connect connection-spec database-type)))
131 (pushnew result *connected-databases*)
132 (setq *default-database* result)
137 (defun disconnect (&key (database *default-database*))
138 "Closes the connection to database. Resets *default-database* if that
139 database was disconnected and only one other connection exists."
140 (when (database-disconnect database)
141 (setq *connected-databases* (delete database *connected-databases*))
142 (when (eq database *default-database*)
143 (setq *default-database* (car *connected-databases*)))
144 (change-class database 'closed-database)
149 ;;; Basic operations on databases
151 (defmethod query (query-expression &key (database *default-database*)
153 "Execute the SQL query expression query-expression on the given database.
154 Returns a list of lists of values of the result of that expression."
155 (database-query query-expression database types))
159 (defmethod execute-command (sql-expression &key (database *default-database*))
160 "Execute the SQL command expression sql-expression on the given database.
161 Returns true on success or nil on failure."
162 (database-execute-command sql-expression database))
166 (defun map-query (output-type-spec function query-expression
167 &key (database *default-database*)
169 "Map the function over all tuples that are returned by the query in
170 query-expression. The results of the function are collected as
171 specified in output-type-spec and returned like in MAP."
172 ;; DANGER Will Robinson: Parts of the code for implementing
173 ;; map-query (including the code below and the helper functions
174 ;; called) are highly CMU CL specific.
175 ;; KMR -- these have been replaced with cross-platform instructions above
176 (macrolet ((type-specifier-atom (type)
177 `(if (atom ,type) ,type (car ,type))))
178 (case (type-specifier-atom output-type-spec)
180 (map-query-for-effect function query-expression database types))
182 (map-query-to-list function query-expression database types))
183 ((simple-vector simple-string vector string array simple-array
184 bit-vector simple-bit-vector base-string
186 (map-query-to-simple output-type-spec function query-expression database types))
188 (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
189 function query-expression :database database :types types)))))
191 (defun map-query-for-effect (function query-expression database types)
192 (multiple-value-bind (result-set columns)
193 (database-query-result-set query-expression database :full-set nil
197 (do ((row (make-list columns)))
198 ((not (database-store-next-row result-set database row))
200 (apply function row))
201 (database-dump-result-set result-set database)))))
203 (defun map-query-to-list (function query-expression database types)
204 (multiple-value-bind (result-set columns)
205 (database-query-result-set query-expression database :full-set nil
209 (let ((result (list nil)))
210 (do ((row (make-list columns))
211 (current-cons result (cdr current-cons)))
212 ((not (database-store-next-row result-set database row))
214 (rplacd current-cons (list (apply function row)))))
215 (database-dump-result-set result-set database)))))
218 (defun map-query-to-simple (output-type-spec function query-expression database types)
219 (multiple-value-bind (result-set columns rows)
220 (database-query-result-set query-expression database :full-set t
225 ;; We know the row count in advance, so we allocate once
227 (cmucl-compat:make-sequence-of-type output-type-spec rows))
228 (row (make-list columns))
229 (index 0 (1+ index)))
230 ((not (database-store-next-row result-set database row))
232 (declare (fixnum index))
233 (setf (aref result index)
234 (apply function row)))
235 ;; Database can't report row count in advance, so we have
236 ;; to grow and shrink our vector dynamically
238 (cmucl-compat:make-sequence-of-type output-type-spec 100))
239 (allocated-length 100)
240 (row (make-list columns))
241 (index 0 (1+ index)))
242 ((not (database-store-next-row result-set database row))
243 (cmucl-compat:shrink-vector result index))
244 (declare (fixnum allocated-length index))
245 (when (>= index allocated-length)
246 (setq allocated-length (* allocated-length 2)
247 result (adjust-array result allocated-length)))
248 (setf (aref result index)
249 (apply function row))))
250 (database-dump-result-set result-set database)))))
252 (defmacro do-query (((&rest args) query-expression
253 &key (database '*default-database*)
256 (let ((result-set (gensym))
260 `(let ((,db ,database))
261 (multiple-value-bind (,result-set ,columns)
262 (database-query-result-set ,query-expression ,db
263 :full-set nil :types ,types)
266 (do ((,row (make-list ,columns)))
267 ((not (database-store-next-row ,result-set ,db ,row))
269 (destructuring-bind ,args ,row
271 (database-dump-result-set ,result-set ,db)))))))