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.lisp,v 1.2 2002/10/14 15:25:15 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 *connect-if-exists* :error
36 "Default value for the if-exists parameter of connect calls.")
38 (defvar *connected-databases* nil
39 "List of active database objects.")
41 (defun connected-databases ()
42 "Return the list of active database objects."
43 *connected-databases*)
45 (defvar *default-database* nil
46 "Specifies the default database to be used.")
48 (defun find-database (database &optional (errorp t))
51 ;; Return the database object itself
54 (or (find database (connected-databases)
60 :format-control "There exists no database called ~A."
61 :format-arguments (list database)))))))
63 (defun connect (connection-spec
64 &key (if-exists *connect-if-exists*)
65 (database-type *default-database-type*)
67 "Connects to a database of the given database-type, using the type-specific
68 connection-spec. if-exists is currently ignored.
69 If pool is t the the connection will be taken from the general pool,
70 if pool is a conn-pool object the connection will be taken from this pool.
73 (acquire-from-pool connection-spec database-type pool)
74 (let* ((db-name (database-name-from-spec connection-spec database-type))
75 (old-db (unless (eq if-exists :new) (find-database db-name nil)))
81 ; (database-connect connection-spec database-type)))
84 (database-connect connection-spec database-type))
85 (warn 'clsql-exists-warning :old-db old-db :new-db result))
88 (error 'clsql-exists-error :old-db old-db)
90 :report "Create a new connection."
92 (database-connect connection-spec database-type)))
94 :report "Use the existing connection."
95 (setq result old-db))))
98 (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
100 (setq result old-db)))
102 (database-connect connection-spec database-type)))
104 (pushnew result *connected-databases*)
105 (setq *default-database* result)
109 (defun disconnect (&key (database *default-database*))
110 "Closes the connection to database. Resets *default-database* if that
111 database was disconnected and only one other connection exists.
112 if the database is from a pool it will be released to this pool."
113 (if (conn-pool database)
114 (release-to-pool database)
115 (when (database-disconnect database)
116 (setq *connected-databases* (delete database *connected-databases*))
117 (when (eq database *default-database*)
118 (setq *default-database* (car *connected-databases*)))
119 (change-class database 'closed-database)
122 ;;; Basic operations on databases
124 (defgeneric query (expression &key database types))
125 (defmethod query (query-expression &key (database *default-database*)
127 "Execute the SQL query expression query-expression on the given database.
128 Returns a list of lists of values of the result of that expression."
129 (database-query query-expression database types))
132 (defgeneric execute-command (expression &key database))
133 (defmethod execute-command (sql-expression &key (database *default-database*))
134 "Execute the SQL command expression sql-expression on the given database.
135 Returns true on success or nil on failure."
136 (database-execute-command sql-expression database))
140 (defun map-query (output-type-spec function query-expression
141 &key (database *default-database*)
143 "Map the function over all tuples that are returned by the query in
144 query-expression. The results of the function are collected as
145 specified in output-type-spec and returned like in MAP."
146 ;; DANGER Will Robinson: Parts of the code for implementing
147 ;; map-query (including the code below and the helper functions
148 ;; called) are highly CMU CL specific.
149 ;; KMR -- these have been replaced with cross-platform instructions above
150 (macrolet ((type-specifier-atom (type)
151 `(if (atom ,type) ,type (car ,type))))
152 (case (type-specifier-atom output-type-spec)
154 (map-query-for-effect function query-expression database types))
156 (map-query-to-list function query-expression database types))
157 ((simple-vector simple-string vector string array simple-array
158 bit-vector simple-bit-vector base-string
160 (map-query-to-simple output-type-spec function query-expression database types))
162 (funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
163 function query-expression :database database :types types)))))
165 (defun map-query-for-effect (function query-expression database types)
166 (multiple-value-bind (result-set columns)
167 (database-query-result-set query-expression database :full-set nil
171 (do ((row (make-list columns)))
172 ((not (database-store-next-row result-set database row))
174 (apply function row))
175 (database-dump-result-set result-set database)))))
177 (defun map-query-to-list (function query-expression database types)
178 (multiple-value-bind (result-set columns)
179 (database-query-result-set query-expression database :full-set nil
183 (let ((result (list nil)))
184 (do ((row (make-list columns))
185 (current-cons result (cdr current-cons)))
186 ((not (database-store-next-row result-set database row))
188 (rplacd current-cons (list (apply function row)))))
189 (database-dump-result-set result-set database)))))
192 (defun map-query-to-simple (output-type-spec function query-expression database types)
193 (multiple-value-bind (result-set columns rows)
194 (database-query-result-set query-expression database :full-set t
199 ;; We know the row count in advance, so we allocate once
201 (cmucl-compat:make-sequence-of-type output-type-spec rows))
202 (row (make-list columns))
203 (index 0 (1+ index)))
204 ((not (database-store-next-row result-set database row))
206 (declare (fixnum index))
207 (setf (aref result index)
208 (apply function row)))
209 ;; Database can't report row count in advance, so we have
210 ;; to grow and shrink our vector dynamically
212 (cmucl-compat:make-sequence-of-type output-type-spec 100))
213 (allocated-length 100)
214 (row (make-list columns))
215 (index 0 (1+ index)))
216 ((not (database-store-next-row result-set database row))
217 (cmucl-compat:shrink-vector result index))
218 (declare (fixnum allocated-length index))
219 (when (>= index allocated-length)
220 (setq allocated-length (* allocated-length 2)
221 result (adjust-array result allocated-length)))
222 (setf (aref result index)
223 (apply function row))))
224 (database-dump-result-set result-set database)))))
226 (defmacro do-query (((&rest args) query-expression
227 &key (database '*default-database*)
230 (let ((result-set (gensym))
234 `(let ((,db ,database))
235 (multiple-value-bind (,result-set ,columns)
236 (database-query-result-set ,query-expression ,db
237 :full-set nil :types ,types)
240 (do ((,row (make-list ,columns)))
241 ((not (database-store-next-row ,result-set ,db ,row))
243 (destructuring-bind ,args ,row
245 (database-dump-result-set ,result-set ,db)))))))
247 ;;; Marc Battyani : Large objects support
249 (defun create-large-object (&key (database *default-database*))
250 "Creates a new large object in the database and returns the object identifier"
251 (database-create-large-object database))
253 (defun write-large-object (object-id data &key (database *default-database*))
254 "Writes data to the large object"
255 (database-write-large-object object-id data database))
257 (defun read-large-object (object-id &key (database *default-database*))
258 "Reads the large object content"
259 (database-read-large-object object-id database))
261 (defun delete-large-object (object-id &key (database *default-database*))
262 "Deletes the large object in the database"
263 (database-delete-large-object object-id database))