;;;; Original code by Pierre R. Mai
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: sql.cl,v 1.5 2002/03/24 22:25:51 kevin Exp $
+;;;; $Id: sql.cl,v 1.12 2002/04/19 20:25:20 marc.battyani Exp $
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :clsql-sys)
-;;;; Modified to use CMUCL-COMPAT library and to fix format strings in
-;;;; error messages
-
-;;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
-
-;;; Conditions
-(define-condition clsql-condition ()
- ())
-
-(define-condition clsql-error (error clsql-condition)
- ())
-
-(define-condition clsql-simple-error (simple-condition clsql-error)
- ())
-
-(define-condition clsql-warning (warning clsql-condition)
- ())
-
-(define-condition clsql-simple-warning (simple-condition clsql-warning)
- ())
-
-(define-condition clsql-invalid-spec-error (clsql-error)
- ((connection-spec :initarg :connection-spec
- :reader clsql-invalid-spec-error-connection-spec)
- (database-type :initarg :database-type
- :reader clsql-invalid-spec-error-database-type)
- (template :initarg :template
- :reader clsql-invalid-spec-error-template))
- (:report (lambda (c stream)
- (format stream "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A"
- (clsql-invalid-spec-error-connection-spec c)
- (clsql-invalid-spec-error-database-type c)
- (clsql-invalid-spec-error-template c)))))
-
-(defmacro check-connection-spec (connection-spec database-type template)
- "Check the connection specification against the provided template,
-and signal an clsql-invalid-spec-error if they don't match."
- `(handler-case
- (destructuring-bind ,template ,connection-spec
- (declare (ignore ,@template))
- t)
- (error () (error 'clsql-invalid-spec-error
- :connection-spec ,connection-spec
- :database-type ,database-type
- :template (quote ,template)))))
-
-(define-condition clsql-connect-error (clsql-error)
- ((database-type :initarg :database-type
- :reader clsql-connect-error-database-type)
- (connection-spec :initarg :connection-spec
- :reader clsql-connect-error-connection-spec)
- (errno :initarg :errno :reader clsql-connect-error-errno)
- (error :initarg :error :reader clsql-connect-error-error))
- (:report (lambda (c stream)
- (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred."
- (database-name-from-spec
- (clsql-connect-error-connection-spec c)
- (clsql-connect-error-database-type c))
- (clsql-connect-error-database-type c)
- (clsql-connect-error-errno c)
- (clsql-connect-error-error c)))))
-
-(define-condition clsql-sql-error (clsql-error)
- ((database :initarg :database :reader clsql-sql-error-database)
- (expression :initarg :expression :reader clsql-sql-error-expression)
- (errno :initarg :errno :reader clsql-sql-error-errno)
- (error :initarg :error :reader clsql-sql-error-error))
- (:report (lambda (c stream)
- (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred."
- (clsql-sql-error-database c)
- (clsql-sql-error-expression c)
- (clsql-sql-error-errno c)
- (clsql-sql-error-error c)))))
-
-(define-condition clsql-database-warning (clsql-warning)
- ((database :initarg :database :reader clsql-database-warning-database)
- (message :initarg :message :reader clsql-database-warning-message))
- (:report (lambda (c stream)
- (format stream "While accessing database ~A~% Warning: ~A~% has occurred."
- (clsql-database-warning-database c)
- (clsql-database-warning-message c)))))
-
-(define-condition clsql-exists-condition (clsql-condition)
- ((old-db :initarg :old-db :reader clsql-exists-condition-old-db)
- (new-db :initarg :new-db :reader clsql-exists-condition-new-db
- :initform nil))
- (:report (lambda (c stream)
- (format stream "In call to ~S:~%" 'connect)
- (cond
- ((null (clsql-exists-condition-new-db c))
- (format stream
- " There is an existing connection ~A to database ~A."
- (clsql-exists-condition-old-db c)
- (database-name (clsql-exists-condition-old-db c))))
- ((eq (clsql-exists-condition-new-db c)
- (clsql-exists-condition-old-db c))
- (format stream
- " Using existing connection ~A to database ~A."
- (clsql-exists-condition-old-db c)
- (database-name (clsql-exists-condition-old-db c))))
- (t
- (format stream
- " Created new connection ~A to database ~A~% ~
-although there is an existing connection (~A)."
- (clsql-exists-condition-new-db c)
- (database-name (clsql-exists-condition-new-db c))
- (clsql-exists-condition-old-db c)))))))
-
-(define-condition clsql-exists-warning (clsql-exists-condition
- clsql-warning)
- ())
-
-(define-condition clsql-exists-error (clsql-exists-condition
- clsql-error)
- ())
-
-(define-condition clsql-closed-error (clsql-error)
- ((database :initarg :database :reader clsql-closed-error-database))
- (:report (lambda (c stream)
- (format stream "The database ~A has already been closed."
- (clsql-closed-error-database c)))))
+;;; Modified by KMR
+;;; - to use CMUCL-COMPAT library
+;;; - fix format strings in error messages
+;;; - use field types
+
+
+;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
+
;;; Database Types
(defvar *loaded-database-types* nil
"Contains a list of database types which have been defined/loaded.")
+(defmethod database-type-load-foreign :after (database-type)
+ (when (database-type-library-loaded database-type)
+ (pushnew database-type *loaded-database-types*)))
+
(defun reload-database-types ()
"Reloads any foreign code for the loaded database types after a dump."
(mapc #'database-type-load-foreign *loaded-database-types*))
-(defgeneric database-type-load-foreign (database-type)
- (:documentation
- "The internal generic implementation of reload-database-types.")
- (:method :after (database-type)
- (pushnew database-type *loaded-database-types*)))
-
-(defgeneric database-type-library-loaded (database-type)
- (:documentation
- "The internal generic implementation for checking if
-database type library loaded successfully."))
-
(defvar *default-database-type* nil
"Specifies the default type of database. Currently only :mysql is
supported.")
(push database-type *initialized-database-types*)
t)))
-(defgeneric database-initialize-database-type (database-type)
- (:documentation
- "The internal generic implementation of initialize-database-type."))
;;; Database handling
(defvar *default-database* nil
"Specifies the default database to be used.")
-(defclass database ()
- ((name :initarg :name :reader database-name))
- (:documentation
- "This class is the supertype of all databases handled by CLSQL."))
-
-(defmethod print-object ((object database) stream)
- (print-unreadable-object (object stream :type t :identity t)
- (write-string (if (slot-boundp object 'name)
- (database-name object)
- "<unbound>")
- stream)))
-
-(defclass closed-database ()
- ((name :initarg :name :reader database-name))
- (:documentation
- "This class represents all databases after they are closed via
-`disconnect'."))
-
-(defmethod print-object ((object closed-database) stream)
- (print-unreadable-object (object stream :type t :identity t)
- (write-string (if (slot-boundp object 'name)
- (database-name object)
- "<unbound>")
- stream)))
-
-(defun signal-closed-database-error (database)
- (cerror "Ignore this error and return nil."
- 'clsql-closed-error
- :database database))
+
(defun find-database (database &optional (errorp t))
(etypecase database
(setq *default-database* result)
result)))
-(defgeneric database-name-from-spec (connection-spec database-type)
- (:documentation
- "Returns the name of the database that would be created if connect
-was called with the connection-spec."))
-(defgeneric database-connect (connection-spec database-type)
- (:documentation "Internal generic implementation of connect."))
(defun disconnect (&key (database *default-database*))
"Closes the connection to database. Resets *default-database* if that
(change-class database 'closed-database)
t))
-(defgeneric database-disconnect (database)
- (:method ((database closed-database))
- (signal-closed-database-error database))
- (:documentation "Internal generic implementation of disconnect."))
+
;;; Basic operations on databases
(defmethod query (query-expression &key (database *default-database*)
- field-types)
+ types)
"Execute the SQL query expression query-expression on the given database.
Returns a list of lists of values of the result of that expression."
- (database-query query-expression database field-types))
+ (database-query query-expression database types))
+
-(defgeneric database-query (query-expression database field-types)
- (:method (query-expression (database closed-database) field-types)
- (declare (ignore query-expression field-types))
- (signal-closed-database-error database))
- (:documentation "Internal generic implementation of query."))
(defmethod execute-command (sql-expression &key (database *default-database*))
"Execute the SQL command expression sql-expression on the given database.
Returns true on success or nil on failure."
(database-execute-command sql-expression database))
-(defgeneric database-execute-command (sql-expression database)
- (:method (sql-expression (database closed-database))
- (declare (ignore sql-expression))
- (signal-closed-database-error database))
- (:documentation "Internal generic implementation of execute-command."))
-
-;;; Mapping and iteration
-(defgeneric database-query-result-set
- (query-expression database &key full-set field-types)
- (:method (query-expression (database closed-database) &key full-set field-types)
- (declare (ignore query-expression full-set field-types))
- (signal-closed-database-error database)
- (values nil nil nil))
- (:documentation
- "Internal generic implementation of query mapping. Starts the
-query specified by query-expression on the given database and returns
-a result-set to be used with database-store-next-row and
-database-dump-result-set to access the returned data. The second
-value is the number of columns in the result-set, if there are any.
-If full-set is true, the number of rows in the result-set is returned
-as a third value, if this is possible (otherwise nil is returned for
-the third value). This might have memory and resource usage
-implications, since many databases will require the query to be
-executed in full to answer this question. If the query produced no
-results then nil is returned for all values that would have been
-returned otherwise. If an error occurs during query execution, the
-function should signal a clsql-sql-error."))
-
-(defgeneric database-dump-result-set (result-set database)
- (:method (result-set (database closed-database))
- (declare (ignore result-set))
- (signal-closed-database-error database))
- (:documentation "Dumps the received result-set."))
-
-(defgeneric database-store-next-row (result-set database list)
- (:method (result-set (database closed-database) list)
- (declare (ignore result-set list))
- (signal-closed-database-error database))
- (:documentation
- "Returns t and stores the next row in the result set in list or
-returns nil when result-set is finished."))
-
(defun map-query (output-type-spec function query-expression
&key (database *default-database*)
- (field-types nil))
+ (types nil))
"Map the function over all tuples that are returned by the query in
query-expression. The results of the function are collected as
specified in output-type-spec and returned like in MAP."
`(if (atom ,type) ,type (car ,type))))
(case (type-specifier-atom output-type-spec)
((nil)
- (map-query-for-effect function query-expression database field-types))
+ (map-query-for-effect function query-expression database types))
(list
- (map-query-to-list function query-expression database field-types))
+ (map-query-to-list function query-expression database types))
((simple-vector simple-string vector string array simple-array
bit-vector simple-bit-vector base-string
simple-base-string)
- (map-query-to-simple output-type-spec function query-expression database field-types))
+ (map-query-to-simple output-type-spec function query-expression database types))
(t
(funcall #'map-query (cmucl-compat:result-type-or-lose output-type-spec t)
- function query-expression :database database :field-types field-types)))))
+ function query-expression :database database :types types)))))
-(defun map-query-for-effect (function query-expression database field-types)
+(defun map-query-for-effect (function query-expression database types)
(multiple-value-bind (result-set columns)
(database-query-result-set query-expression database :full-set nil
- :field-types field-types)
+ :types types)
(when result-set
(unwind-protect
(do ((row (make-list columns)))
(apply function row))
(database-dump-result-set result-set database)))))
-(defun map-query-to-list (function query-expression database field-types)
+(defun map-query-to-list (function query-expression database types)
(multiple-value-bind (result-set columns)
(database-query-result-set query-expression database :full-set nil
- :field-types field-types)
+ :types types)
(when result-set
(unwind-protect
(let ((result (list nil)))
(database-dump-result-set result-set database)))))
-(defun map-query-to-simple (output-type-spec function query-expression database field-types)
+(defun map-query-to-simple (output-type-spec function query-expression database types)
(multiple-value-bind (result-set columns rows)
(database-query-result-set query-expression database :full-set t
- :field-types field-types)
+ :types types)
(when result-set
(unwind-protect
(if rows
(defmacro do-query (((&rest args) query-expression
&key (database '*default-database*)
- (field-types nil))
+ (types nil))
&body body)
(let ((result-set (gensym))
(columns (gensym))
`(let ((,db ,database))
(multiple-value-bind (,result-set ,columns)
(database-query-result-set ,query-expression ,db
- :full-set nil :field-types ,field-types)
+ :full-set nil :types ,types)
(when ,result-set
(unwind-protect
(do ((,row (make-list ,columns)))
,@body))
(database-dump-result-set ,result-set ,db)))))))
+;;; Marc Battyani : Large objects support
+
+(defun create-large-object (&key (database *default-database*))
+ "Creates a new large object in the database and returns the object identifier"
+ (database-create-large-object database))
+
+(defun write-large-object (object-id data &key (database *default-database*))
+ "Writes data to the large object"
+ (database-write-large-object object-id data database))
+(defun read-large-object (object-id &key (database *default-database*))
+ "Reads the large object content"
+ (database-read-large-object object-id database))
+(defun delete-large-object (object-id &key (database *default-database*))
+ "Deletes the large object in the database"
+ (database-delete-large-object object-id database))