X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fsql.cl;h=101d30f128619f28d6577920ff5df267ea58abd2;hp=696997409761613c5f513f462a3e7e065e715838;hb=998937376fa6f9ce29bd3c7954fb0ebca91c37d7;hpb=8213ff48f5362c3d4792444c929f50bd128bd044

diff --git a/sql/sql.cl b/sql/sql.cl
index 6969974..101d30f 100644
--- a/sql/sql.cl
+++ b/sql/sql.cl
@@ -8,7 +8,7 @@
 ;;;;                 Original code by Pierre R. Mai 
 ;;;; Date Started:  Feb 2002
 ;;;;
-;;;; $Id: sql.cl,v 1.1 2002/03/23 14:04:54 kevin Exp $
+;;;; $Id: sql.cl,v 1.19 2002/09/17 17:16:43 kevin Exp $
 ;;;;
 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
 ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai
@@ -21,163 +21,14 @@
 (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
+;;; 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
 
-;;; Conditions
-(define-condition clsql-condition ()
-  ())
+;;; Simple implementation of SQL along the lines of Harlequin's Common SQL
 
-(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)))))
-
-;;; Database Types
-
-(defvar *loaded-database-types* nil
-  "Contains a list of database types which have been defined/loaded.")
-
-(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*)))
-
-(defvar *default-database-type* nil
-  "Specifies the default type of database.  Currently only :mysql is
-supported.")
-
-(defvar *initialized-database-types* nil
-  "Contains a list of database types which have been initialized by calls
-to initialize-database-type.")
-
-(defun initialize-database-type (&key (database-type *default-database-type*))
-  "Initialize the given database-type, if it is not already
-initialized, as indicated by `*initialized-database-types*'."
-  (if (member database-type *initialized-database-types*)
-      t
-      (when (database-initialize-database-type database-type)
-	(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
 
@@ -194,36 +45,6 @@ initialized, as indicated by `*initialized-database-types*'."
 (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
     (database
@@ -241,31 +62,37 @@ initialized, as indicated by `*initialized-database-types*'."
 
 (defun connect (connection-spec
 		&key (if-exists *connect-if-exists*)
-		(database-type *default-database-type*))
+		(database-type *default-database-type*)
+		(pool nil))
   "Connects to a database of the given database-type, using the type-specific
-connection-spec.  if-exists is currently ignored."
-  (let* ((db-name (database-name-from-spec connection-spec database-type))
-	 (old-db (find-database db-name nil))
-	 (result nil))
-    (if old-db
+connection-spec.  if-exists is currently ignored.
+If pool is t the the connection will be taken from the general pool,
+if pool is a conn-pool object the connection will be taken from this pool.
+"
+  (if pool
+    (acquire-from-pool connection-spec database-type pool)
+    (let* ((db-name (database-name-from-spec connection-spec database-type))
+	   (old-db (unless (eq if-exists :new) (find-database db-name nil)))
+	   (result nil))
+      (if old-db
 	(case if-exists
-	  (:new
-	   (setq result
-		 (database-connect connection-spec database-type)))
+;	    (:new
+;	     (setq result
+;	       (database-connect connection-spec database-type)))
 	  (:warn-new
 	   (setq result
 		 (database-connect connection-spec database-type))
 	   (warn 'clsql-exists-warning :old-db old-db :new-db result))
 	  (:error
 	   (restart-case
-	       (error 'clsql-exists-error :old-db old-db)
-	     (create-new ()
-	       :report "Create a new connection."
-	       (setq result
-		     (database-connect connection-spec database-type)))
-	     (use-old ()
-	       :report "Use the existing connection."
-	       (setq result old-db))))
+		 (error 'clsql-exists-error :old-db old-db)
+	       (create-new ()
+		   :report "Create a new connection."
+		 (setq result
+		   (database-connect connection-spec database-type)))
+	       (use-old ()
+		   :report "Use the existing connection."
+		 (setq result old-db))))
 	  (:warn-old
 	   (setq result old-db)
 	   (warn 'clsql-exists-warning :old-db old-db :new-db old-db))
@@ -273,98 +100,45 @@ connection-spec.  if-exists is currently ignored."
 	   (setq result old-db)))
 	(setq result
 	      (database-connect connection-spec database-type)))
-    (when result
-      (pushnew result *connected-databases*)
-      (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."))
+      (when result
+	(pushnew result *connected-databases*)
+	(setq *default-database* result)
+	result))))
 
-(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
-database was disconnected and only one other connection exists."
-  (when (database-disconnect database)
-    (setq *connected-databases* (delete database *connected-databases*))
-    (when (eq database *default-database*)
-      (setq *default-database* (car *connected-databases*)))
-    (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."))
+database was disconnected and only one other connection exists.
+if the database is from a pool it will be released to this pool."
+  (if (conn-pool database)
+      (release-to-pool database)
+    (when (database-disconnect database)
+      (setq *connected-databases* (delete database *connected-databases*))
+      (when (eq database *default-database*)
+	(setq *default-database* (car *connected-databases*)))
+      (change-class database 'closed-database)
+      t)))
 
 ;;; Basic operations on databases
 
-(defmethod query (query-expression &key (database *default-database*))
+(defmethod query (query-expression &key (database *default-database*)  
+		  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))
+  (database-query query-expression database types))
+
 
-(defgeneric database-query (query-expression database)
-  (:method (query-expression (database closed-database))
-	   (declare (ignore query-expression))
-	   (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 &optional full-set)
-  (:method (query-expression (database closed-database) &optional full-set)
-	   (declare (ignore query-expression full-set))
-	   (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*))
+		  &key (database *default-database*)
+		  (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."
@@ -375,20 +149,22 @@ specified in output-type-spec and returned like in MAP."
   (macrolet ((type-specifier-atom (type)
 	       `(if (atom ,type) ,type (car ,type))))
     (case (type-specifier-atom output-type-spec)
-      ((nil) (map-query-for-effect function query-expression database))
-      (list (map-query-to-list function query-expression database))
+      ((nil) 
+       (map-query-for-effect function query-expression database types))
+      (list 
+       (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))
+       (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)))))
+              function query-expression :database database :types types)))))
 
-(defun map-query-for-effect (function query-expression database)
+(defun map-query-for-effect (function query-expression database types)
   (multiple-value-bind (result-set columns)
-      (database-query-result-set query-expression database)
+      (database-query-result-set query-expression database :full-set nil
+				 :types types)
     (when result-set
       (unwind-protect
 	   (do ((row (make-list columns)))
@@ -397,9 +173,10 @@ specified in output-type-spec and returned like in MAP."
 	     (apply function row))
 	(database-dump-result-set result-set database)))))
 		     
-(defun map-query-to-list (function query-expression database)
+(defun map-query-to-list (function query-expression database types)
   (multiple-value-bind (result-set columns)
-      (database-query-result-set query-expression database)
+      (database-query-result-set query-expression database :full-set nil
+				 :types types)
     (when result-set
       (unwind-protect
 	   (let ((result (list nil)))
@@ -411,9 +188,10 @@ specified in output-type-spec and returned like in MAP."
 	(database-dump-result-set result-set database)))))
 
 
-(defun map-query-to-simple (output-type-spec function query-expression database)
+(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 t)
+      (database-query-result-set query-expression database :full-set t
+				 :types types)
     (when result-set
       (unwind-protect
 	   (if rows
@@ -445,7 +223,8 @@ specified in output-type-spec and returned like in MAP."
 	(database-dump-result-set result-set database)))))
 
 (defmacro do-query (((&rest args) query-expression
-		     &key (database '*default-database*))
+		     &key (database '*default-database*)
+		     (types nil))
 		    &body body)
   (let ((result-set (gensym))
 	(columns (gensym))
@@ -453,7 +232,8 @@ specified in output-type-spec and returned like in MAP."
 	(db (gensym)))
     `(let ((,db ,database))
        (multiple-value-bind (,result-set ,columns)
-	   (database-query-result-set ,query-expression ,db)
+	   (database-query-result-set ,query-expression ,db
+				      :full-set nil :types ,types)
 	 (when ,result-set
 	   (unwind-protect
 		(do ((,row (make-list ,columns)))
@@ -463,5 +243,20 @@ specified in output-type-spec and returned like in MAP."
 		    ,@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))