X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fsql.cl;h=310001eb221defd1860adb513c293d640fd3ff81;hb=b55c36d4d3835550407db78b1baa76a0bffdc5c1;hp=92d0e4452aeb50185bc974003eb3b0456797f404;hpb=1a44400b42310a985f1a27ea8f53da84716955e1;p=clsql.git diff --git a/sql/sql.cl b/sql/sql.cl index 92d0e44..310001e 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.10 2002/03/29 08:23:38 kevin Exp $ +;;;; $Id: sql.cl,v 1.15 2002/05/03 20:50:18 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 @@ -35,6 +35,10 @@ (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*)) @@ -72,8 +76,6 @@ initialized, as indicated by `*initialized-database-types*'." (defvar *default-database* nil "Specifies the default database to be used.") - - (defun find-database (database &optional (errorp t)) (etypecase database (database @@ -91,56 +93,62 @@ 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." +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. +" (let* ((db-name (database-name-from-spec connection-spec database-type)) - (old-db (find-database db-name nil)) + (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))) - (: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)))) - (:warn-old - (setq result old-db) - (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) - (:old - (setq result old-db))) + (if pool + (setq result (acquire-from-pool connection-spec database-type pool)) + (if old-db + (case if-exists +; (: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)))) + (:warn-old + (setq result old-db) + (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) + (:old + (setq result old-db))) (setq result - (database-connect connection-spec database-type))) + (database-connect connection-spec database-type)))) (when result (pushnew result *connected-databases*) (setq *default-database* result) result))) - (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)) - - +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 @@ -266,5 +274,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))