From: Kevin M. Rosenberg Date: Tue, 6 Apr 2004 03:57:44 +0000 (+0000) Subject: r8822: now passes some of the regression tests X-Git-Tag: v3.8.6~745 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=3da1a0ba2b4ded66dca0bec9c4e23457eb7ff079 r8822: now passes some of the regression tests --- diff --git a/base/package.lisp b/base/package.lisp index f819759..ba3eeec 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -57,7 +57,7 @@ ;; Support for pooled connections #:database-type - + ;; Large objects (Marc B) #:database-create-large-object #:database-write-large-object @@ -118,7 +118,7 @@ #:transaction #:transaction-level #:conn-pool - + ;; utils.lisp #:number-to-sql-string #:float-to-sql-string @@ -223,6 +223,7 @@ #:status ; database xx #:with-database #:with-default-database + #:disconnect-pooled ;; basic-sql.lisp #:query diff --git a/clsql-usql-tests.asd b/clsql-usql-tests.asd index e60abab..07cbdbd 100644 --- a/clsql-usql-tests.asd +++ b/clsql-usql-tests.asd @@ -24,6 +24,7 @@ :description "A regression test suite for CLSQL-USQL." :components ((:module usql-tests + :serial t :components ((:file "package") (:file "test-init") (:file "test-connection") diff --git a/clsql-usql.asd b/clsql-usql.asd index 428fb14..e10d556 100644 --- a/clsql-usql.asd +++ b/clsql-usql.asd @@ -24,16 +24,14 @@ based on the Xanalys CommonSQL interface for Lispworks. It depends on the low-level database interfaces provided by CLSQL and includes both a functional and an object oriented interface." + :depends-on (clsql-base) :components ((:module usql :components - ((:module :patches + ((:module :package :pathname "" - :components (#+(or cmu sbcl) (:file "pcl-patch"))) - (:module :package - :pathname "" - :components ((:file "package")) - :depends-on (:patches)) + :components ((:file "package") + (:file "kmr-mop" :depends-on ("package")))) (:module :core :pathname "" :components ((:file "classes") @@ -47,8 +45,7 @@ a functional and an object oriented interface." :depends-on (:core)) (:module :object :pathname "" - :components ((:file "metaclasses") - (:file "objects" :depends-on ("metaclasses"))) - :depends-on (:functional))))) - :depends-on (:clsql-base)) + :components ((:file "metaclasses") + (:file "objects" :depends-on ("metaclasses"))) + :depends-on (:functional)))))) diff --git a/sql/package.lisp b/sql/package.lisp index bb76d3e..7d8b8b2 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -69,10 +69,50 @@ #:closed-database #:database-name-from-spec - ;; utils.cl + ;; utils.lisp #:number-to-sql-string #:float-to-sql-string #:sql-escape-quotes + + ;; database.lisp -- Connection + #:*default-database-type* ; clsql-base xx + #:*default-database* ; classes xx + #:connect ; database xx + #:*connect-if-exists* ; database xx + #:connected-databases ; database xx + #:database ; database xx + #:database-name ; database xx + #:disconnect ; database xx + #:reconnect ; database + #:find-database ; database xx + #:status ; database xx + #:with-database + #:with-default-database + + ;; basic-sql.lisp + #:query + #:execute-command + #:write-large-object + #:read-large-object + #:delete-large-object + + ;; Transactions + #:with-transaction + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + #:commit ; transact xx + #:rollback ; transact xx + #:with-transaction ; transact xx . + #:start-transaction ; transact xx + #:in-transaction-p ; transact xx + #:database-start-transaction + #:database-abort-transaction + #:database-commit-transaction + #:transaction-level + #:transaction + #:disconnect-pooled )) (:export ;; sql.cl diff --git a/usql-tests/package.lisp b/usql-tests/package.lisp index aa44d8b..7d111d6 100644 --- a/usql-tests/package.lisp +++ b/usql-tests/package.lisp @@ -14,15 +14,10 @@ ;;;; ====================================================================== -(in-package :cl-user) +(in-package #:cl-user) -(eval-when (:compile-toplevel :load-toplevel :execute) - -(defpackage :clsql-usql-tests - (:nicknames :usql-tests) - (:use :clsql-usql :common-lisp :rtest) - (:export :test-usql :test-initialise-database :test-connect-to-database) +(defpackage #:clsql-usql-tests + (:nicknames #:usql-tests) + (:use #:clsql-usql #:common-lisp #:rtest) + (:export #:test-usql #:test-initialise-database #:test-connect-to-database) (:documentation "Regression tests for CLSQL-USQL.")) - -); eval-when - diff --git a/usql-tests/test-fdml.lisp b/usql-tests/test-fdml.lisp index e24bbc6..ae986fa 100644 --- a/usql-tests/test-fdml.lisp +++ b/usql-tests/test-fdml.lisp @@ -23,7 +23,7 @@ (progn (usql:insert-records :into [employee] :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" - 1 1 1.85 t ,(usql:get-time))) + 1 1 1.85 t ,(clsql-base:get-time))) (values (usql:select [first-name] [last-name] [email] :from [employee] :where [= [emplid] 11]) @@ -392,4 +392,4 @@ (apply #'values (nreverse results))))))) nil nil ("lenin@soviet.org")) -#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file +#.(usql:restore-sql-reader-syntax-state) diff --git a/usql-tests/test-init.lisp b/usql-tests/test-init.lisp index 67ad1e9..3076a21 100644 --- a/usql-tests/test-init.lisp +++ b/usql-tests/test-init.lisp @@ -13,7 +13,7 @@ ;;;; ;;;; ====================================================================== -(in-package :clsql-usql-tests) +(in-package #:clsql-usql-tests) (defvar *test-database-type* nil) (defvar *test-database-server* "") @@ -121,7 +121,7 @@ :groupid 1 :married t :height (1+ (random 1.00)) - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Vladamir" :last-name "Lenin" :email "lenin@soviet.org")) @@ -131,7 +131,7 @@ :groupid 1 :height (1+ (random 1.00)) :married t - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Josef" :last-name "Stalin" :email "stalin@soviet.org")) @@ -141,7 +141,7 @@ :groupid 1 :height (1+ (random 1.00)) :married t - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Leon" :last-name "Trotsky" :email "trotsky@soviet.org")) @@ -151,7 +151,7 @@ :groupid 1 :height (1+ (random 1.00)) :married nil - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Nikita" :last-name "Kruschev" :email "kruschev@soviet.org")) @@ -161,7 +161,7 @@ :groupid 1 :married nil :height (1+ (random 1.00)) - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Leonid" :last-name "Brezhnev" :email "brezhnev@soviet.org")) @@ -171,7 +171,7 @@ :groupid 1 :married nil :height (1+ (random 1.00)) - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Yuri" :last-name "Andropov" :email "andropov@soviet.org")) @@ -181,7 +181,7 @@ :groupid 1 :height (1+ (random 1.00)) :married nil - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Konstantin" :last-name "Chernenko" :email "chernenko@soviet.org")) @@ -191,7 +191,7 @@ :groupid 1 :height (1+ (random 1.00)) :married nil - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Mikhail" :last-name "Gorbachev" :email "gorbachev@soviet.org")) @@ -201,7 +201,7 @@ :groupid 1 :married nil :height (1+ (random 1.00)) - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Boris" :last-name "Yeltsin" :email "yeltsin@soviet.org")) @@ -211,7 +211,7 @@ :groupid 1 :married nil :height (1+ (random 1.00)) - :birthday (usql:get-time) + :birthday (clsql-base:get-time) :first-name "Vladamir" :last-name "Putin" :email "putin@soviet.org")) diff --git a/usql-tests/test-ooddl.lisp b/usql-tests/test-ooddl.lisp index cabf06a..aed7700 100644 --- a/usql-tests/test-ooddl.lisp +++ b/usql-tests/test-ooddl.lisp @@ -58,7 +58,7 @@ "Lenin") (deftest :ooddl/time/1 - (let* ((now (usql:get-time))) + (let* ((now (clsql-base:get-time))) (when (member *test-database-type* '(:postgresql :postgresql-socket)) (usql:execute-command "set datestyle to 'iso'")) (usql:update-records [employee] :av-pairs `((birthday ,now)) @@ -66,11 +66,11 @@ (let ((dbobj (car (usql:select 'employee :where [= [birthday] now])))) (values (slot-value dbobj 'last-name) - (usql:time= (slot-value dbobj 'birthday) now)))) + (clsql-base:time= (slot-value dbobj 'birthday) now)))) "Lenin" t) (deftest :ooddl/time/2 - (let* ((now (usql:get-time)) + (let* ((now (clsql-base:get-time)) (fail-index -1)) (when (member *test-database-type* '(:postgresql :postgresql-socket)) (usql:execute-command "set datestyle to 'iso'")) @@ -78,10 +78,10 @@ (usql:update-records [employee] :av-pairs `((birthday ,now)) :where [= [emplid] 1]) (let ((dbobj (car (usql:select 'employee :where [= [birthday] now])))) - (unless (usql:time= (slot-value dbobj 'birthday) now) + (unless (clsql-base:time= (slot-value dbobj 'birthday) now) (setf fail-index x)) - (setf now (usql:roll now :day (* 10 x))))) + (setf now (clsql-base:roll now :day (* 10 x))))) fail-index) -1) -#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file +#.(usql:restore-sql-reader-syntax-state) diff --git a/usql/classes.lisp b/usql/classes.lisp index 7a11ddb..c390c5f 100644 --- a/usql/classes.lisp +++ b/usql/classes.lisp @@ -12,12 +12,9 @@ ;;;; ;;;; ====================================================================== -(in-package :clsql-usql-sys) +(in-package #:clsql-usql-sys) -(defvar *default-database* nil - "Specifies the default database to be used.") - (defvar +empty-string+ "''") (defvar +null-string+ "NULL") diff --git a/usql/kmr-mop.lisp b/usql/kmr-mop.lisp new file mode 100644 index 0000000..32cc35d --- /dev/null +++ b/usql/kmr-mop.lisp @@ -0,0 +1,48 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmr-mop.lisp +;;;; Purpose: MOP support for multiple-implementions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id: mop.lisp 8573 2004-01-29 23:30:50Z kevin $ +;;;; +;;;; This file was extracted from the KMRCL utilities +;;;; ************************************************************************* + +;;; This file imports MOP symbols into the USQL-MOP package and then +;;; re-exports into CLSQL-USQL-SYS them to hide differences in +;;; MOP implementations. + +(in-package #:clsql-usql-sys) + +#+lispworks +(defun intern-eql-specializer (slot) + `(eql ,slot)) + +(defmacro process-class-option (metaclass slot-name &optional required) + #+lispworks + `(defmethod clos:process-a-class-option ((class ,metaclass) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name)) + (list name `',value)) + #-lispworks + (declare (ignore metaclass slot-name required)) + ) + +(defmacro process-slot-option (metaclass slot-name) + #+lispworks + `(defmethod clos:process-a-slot-option ((class ,metaclass) + (option (eql ,slot-name)) + value + already-processed-options + slot) + (list* option `',value already-processed-options)) + #-lispworks + (declare (ignore metaclass slot-name)) + ) + diff --git a/usql/metaclasses.lisp b/usql/metaclasses.lisp index d72985e..6332d9e 100644 --- a/usql/metaclasses.lisp +++ b/usql/metaclasses.lisp @@ -11,7 +11,27 @@ ;;;; ;;;; ====================================================================== -(in-package :clsql-usql-sys) + +(in-package #:clsql-usql-sys) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'compute-effective-slot-definition))) + 3) + (pushnew :kmr-normal-cesd cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'direct-slot-definition-class))) + 3) + (pushnew :kmr-normal-dsdc cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'effective-slot-definition-class))) + 3) + (pushnew :kmr-normal-esdc cl:*features*))) ;; ------------------------------------------------------------ @@ -125,14 +145,10 @@ of the default method. The extra allowed options are the value of the result)) -(defmethod validate-superclass ((class standard-class) - (superclass standard-db-class)) - t) - +#+(or cmu scl sbcl openmcl) (defmethod validate-superclass ((class standard-db-class) - (superclass standard-class)) - t) - + (superclass standard-class)) + t) (defun table-name-from-arg (arg) (cond ((symbolp arg) @@ -262,10 +278,17 @@ of the default method. The extra allowed options are the value of the (setq all-slots (remove-if #'not-db-col all-slots)) (setq all-slots (stable-sort all-slots #'string< :key #'car)) (setf (object-definition class) all-slots - (key-slots class) (remove-if-not (lambda (slot) - (eql (slot-value slot 'db-kind) - :key)) - (class-slots class)))))) + (key-slots class) (remove-if-not (lambda (slot) + (eql (slot-value slot 'db-kind) + :key)) + (class-slots class)))))) + +#+allegro +(defmethod finalize-inheritance :after ((class standard-db-class)) + (setf (key-slots class) (remove-if-not (lambda (slot) + (eql (slot-value slot 'db-kind) + :key)) + (class-slots class)))) ;; return the deepest view-class ancestor for a given view class @@ -402,14 +425,14 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") ()) (defmethod direct-slot-definition-class ((class standard-db-class) - #-cmu &rest + #+kmr-normal-dsdc &rest initargs) (declare (ignore initargs)) (find-class 'view-class-direct-slot-definition)) (defmethod effective-slot-definition-class ((class standard-db-class) - #-cmu &rest - initargs) + #+kmr-normal-esdc &rest + initargs) (declare (ignore initargs)) (find-class 'view-class-effective-slot-definition)) @@ -418,10 +441,9 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") ;; verifies the column name. (defmethod compute-effective-slot-definition ((class standard-db-class) - #-cmu slot-name + #+kmr-normal-cesd slot-name direct-slots) - ;(declare (ignore #-cmu slot-name direct-slots)) - (declare (ignore #-cmu slot-name)) + #+kmr-normal-cesd (declare (ignore slot-name)) (let ((slotd (call-next-method)) (sd (car direct-slots))) @@ -493,3 +515,12 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (find-if #'(lambda (d) (eql slot (slot-definition-name d))) (class-slots class))) +#+ignore +(eval-when (:compile-toplevel :load-toplevel :execute) + #+kmr-normal-cesd + (setq cl:*features* (delete :kmr-normal-cesd cl:*features*)) + #+kmr-normal-dsdc + (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*)) + #+kmr-normal-esdc + (setq cl:*features* (delete :kmr-normal-esdc cl:*features*)) + ) diff --git a/usql/objects.lisp b/usql/objects.lisp index 757848c..0478c8f 100644 --- a/usql/objects.lisp +++ b/usql/objects.lisp @@ -43,7 +43,8 @@ (call-next-method)) (defmethod (setf slot-value-using-class) (new-value (class standard-db-class) - instance slot) + instance slot) + (declare (ignore new-value instance slot)) (call-next-method)) ;; JMM - Can't go around trying to slot-access a symbol! Guess in @@ -770,7 +771,6 @@ DATABASE-NULL-VALUE on the type of the slot.")) "VARCHAR(255)"))) (defmethod database-get-type-specifier ((type (eql 'string)) args database) - (declare (ignore database)) (if args (format nil "VARCHAR(~A)" (car args)) (if (member (database-type database) '(:postgresql :postgresql-socket)) diff --git a/usql/package.lisp b/usql/package.lisp index 17bb441..51fb6ec 100644 --- a/usql/package.lisp +++ b/usql/package.lisp @@ -1,7 +1,7 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ====================================================================== ;;;; File: package.lisp -;;;; Author: Marcus Pearce +;;;; Author: Marcus Pearce , Kevin Rosenberg ;;;; Created: 30/03/2004 ;;;; Updated: <04/04/2004 12:21:50 marcusp> ;;;; ====================================================================== @@ -16,104 +16,201 @@ (in-package #:cl-user) (eval-when (:compile-toplevel :load-toplevel :execute) - -(defpackage #:clsql-usql-sys - (:nicknames #:usql-sys #:sql-sys) - (:use #:common-lisp #:clsql-base-sys #+lispworks #:clos) - ;; This is for working with the CMUCL/SBCL PCL MOP, which is kinda whacky - #+(or cmu sbcl) - (:shadowing-import-from #+cmu :pcl #+sbcl :sb-pcl - :built-in-class - :class-direct-slots - :class-name - :class-of - :class-slots - :compute-effective-slot-definition - :direct-slot-definition-class - :effective-slot-definition-class - :find-class - :slot-boundp - :slot-definition-name - :slot-definition-type - :slot-value-using-class - :standard-direct-slot-definition - :standard-effective-slot-definition - :validate-superclass - :class-direct-superclasses - :name - :standard-class) - (:import-from :clsql-base-sys - ;; conditions - :clsql-condition - :clsql-error - :clsql-simple-error - :clsql-warning - :clsql-simple-warning - :clsql-invalid-spec-error - :clsql-invalid-spec-error-connection-spec - :clsql-invalid-spec-error-database-type - :clsql-invalid-spec-error-template - :clsql-connect-error - :clsql-connect-error-database-type - :clsql-connect-error-connection-spec - :clsql-connect-error-errno - :clsql-connect-error-error - :clsql-sql-error - :clsql-sql-error-database - :clsql-sql-error-expression - :clsql-sql-error-errno - :clsql-sql-error-error - :clsql-database-warning - :clsql-database-warning-database - :clsql-database-warning-message - :clsql-exists-condition - :clsql-exists-condition-new-db - :clsql-exists-condition-old-db - :clsql-exists-warning - :clsql-exists-error - :clsql-closed-error - :clsql-closed-error-database - :clsql-type-error - :clsql-sql-syntax-error - ;; db-interface - :check-connection-spec - :database-initialize-database-type - :database-type-load-foreign - :database-name-from-spec - :database-create-sequence - :database-drop-sequence - :database-sequence-next - :database-set-sequence-position - :database-query-result-set - :database-dump-result-set - :database-store-next-row - :database-get-type-specifier - :database-list-tables - :database-list-views - :database-list-indexes - :database-list-sequences - :database-list-attributes - :database-attribute-type - :database-add-attribute - :database-type - ;; initialize - :*loaded-database-types* - :reload-database-types - :*default-database-type* - :*initialized-database-types* - :initialize-database-type - ;; classes - :database - :closed-database - :database-name - :command-recording-stream - :result-recording-stream - :database-view-classes - :database-schema - :conn-pool - :print-object - ;; utils - :sql-escape) + +#+sbcl + (if (find-package 'sb-mop) + (pushnew :usql-sbcl-mop cl:*features*) + (pushnew :usql-sbcl-pcl cl:*features*)) + + #+cmu + (if (eq (symbol-package 'pcl:find-class) + (find-package 'common-lisp)) + (pushnew :usql-cmucl-mop cl:*features*) + (pushnew :usql-cmucl-pcl cl:*features*))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:clsql-usql-sys + (:nicknames #:usql-sys) + (:use #:common-lisp #:clsql-base-sys + #+usql-sbcl-mop #:sb-mop + #+usql-cmucl-mop #:mop + #+allegro #:mop + #+lispworks #:clos + #+scl #:clos + #+openmcl #:openmcl-mop) + + #+allegro + (:shadowing-import-from + #:excl) + #+lispworks + (:shadowing-import-from + #:clos) + #+usql-sbcl-mop + (:shadowing-import-from + #:sb-pcl + #:generic-function-lambda-list) + #+usql-sbcl-pcl + (:shadowing-import-from + #:sb-pcl + #:name + #:class-direct-slots + #:class-of #:class-name #:class-slots #:find-class + #:slot-boundp + #:standard-class + #:slot-definition-name #:finalize-inheritance + #:standard-direct-slot-definition + #:standard-effective-slot-definition #:validate-superclass + #:direct-slot-definition-class #:compute-effective-slot-definition + #:effective-slot-definition-class + #:slot-value-using-class + #:class-prototype #:generic-function-method-class #:intern-eql-specializer + #:make-method-lambda #:generic-function-lambda-list + #:class-precedence-list #:slot-definition-type + #:class-direct-superclasses) + #+usql-cmucl-mop + (:shadowing-import-from + #:pcl + #:generic-function-lambda-list) + #+usql-cmucl-pcl + (:shadowing-import-from + #:pcl + #:class-direct-slots + #:name + #:class-of #:class-name #:class-slots #:find-class #:standard-class + #:slot-boundp + #:slot-definition-name #:finalize-inheritance + #:standard-direct-slot-definition #:standard-effective-slot-definition + #:validate-superclass #:direct-slot-definition-class + #:effective-slot-definition-class + #:compute-effective-slot-definition + #:slot-value-using-class + #:class-prototype #:generic-function-method-class #:intern-eql-specializer + #:make-method-lambda #:generic-function-lambda-list + #:class-precedence-list #:slot-definition-type + #:class-direct-superclasses) + #+scl + (:shadowing-import-from + #:clos + #:class-prototype ;; note: make-method-lambda is not fbound + ) + + (:import-from + #:clsql-base-sys + . + #1=( + ;; conditions + :clsql-condition + :clsql-error + :clsql-simple-error + :clsql-warning + :clsql-simple-warning + :clsql-invalid-spec-error + :clsql-invalid-spec-error-connection-spec + :clsql-invalid-spec-error-database-type + :clsql-invalid-spec-error-template + :clsql-connect-error + :clsql-connect-error-database-type + :clsql-connect-error-connection-spec + :clsql-connect-error-errno + :clsql-connect-error-error + :clsql-sql-error + :clsql-sql-error-database + :clsql-sql-error-expression + :clsql-sql-error-errno + :clsql-sql-error-error + :clsql-database-warning + :clsql-database-warning-database + :clsql-database-warning-message + :clsql-exists-condition + :clsql-exists-condition-new-db + :clsql-exists-condition-old-db + :clsql-exists-warning + :clsql-exists-error + :clsql-closed-error + :clsql-closed-error-database + :clsql-type-error + :clsql-sql-syntax-error + + ;; db-interface + :check-connection-spec + :database-initialize-database-type + :database-type-load-foreign + :database-name-from-spec + :database-create-sequence + :database-drop-sequence + :database-sequence-next + :database-set-sequence-position + :database-query-result-set + :database-dump-result-set + :database-store-next-row + :database-get-type-specifier + :database-list-tables + :database-list-views + :database-list-indexes + :database-list-sequences + :database-list-attributes + :database-attribute-type + :database-add-attribute + :database-type + ;; initialize + :*loaded-database-types* + :reload-database-types + :*default-database-type* + :*initialized-database-types* + :initialize-database-type + ;; classes + :database + :closed-database + :database-name + :command-recording-stream + :result-recording-stream + :database-view-classes + :database-schema + :conn-pool + :print-object + ;; utils + :sql-escape + + ;; database.lisp -- Connection + #:*default-database-type* ; clsql-base xx + #:*default-database* ; classes xx + #:connect ; database xx + #:*connect-if-exists* ; database xx + #:connected-databases ; database xx + #:database ; database xx + #:database-name ; database xx + #:disconnect ; database xx + #:reconnect ; database + #:find-database ; database xx + #:status ; database xx + #:with-database + #:with-default-database + + ;; basic-sql.lisp + #:query + #:execute-command + #:write-large-object + #:read-large-object + #:delete-large-object + + ;; Transactions + #:with-transaction + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + #:commit ; transact xx + #:rollback ; transact xx + #:with-transaction ; transact xx . + #:start-transaction ; transact xx + #:in-transaction-p ; transact xx + #:database-start-transaction + #:database-abort-transaction + #:database-commit-transaction + #:transaction-level + #:transaction + )) (:export ;; "Private" exports for use by interface packages :check-connection-spec @@ -146,7 +243,7 @@ ;; I = Implemented, D = Documented ;; name file ID ;;==================================================== - #1=(;;------------------------------------------------ + #2=(;;------------------------------------------------ ;; CommonSQL API ;;------------------------------------------------ ;;FDML @@ -234,37 +331,6 @@ :database-get-type-specifier ; objects x :database-output-sql ; sql/class xx - ;;----------------------------------------------- - ;; Conditions/Warnings/Errors - ;;----------------------------------------------- - :clsql-condition - :clsql-error - :clsql-simple-error - :clsql-warning - :clsql-simple-warning - :clsql-invalid-spec-error - :clsql-invalid-spec-error-connection-spec - :clsql-invalid-spec-error-database-type - :clsql-invalid-spec-error-template - :clsql-connect-error - :clsql-connect-error-database-type - :clsql-connect-error-connection-spec - :clsql-connect-error-errno - :clsql-connect-error-error - :clsql-sql-error - :clsql-type-error - :clsql-sql-error-database - :clsql-sql-error-expression - :clsql-sql-error-errno - :clsql-sql-error-error - :clsql-exists-condition - :clsql-exists-condition-new-db - :clsql-exists-condition-old-db - :clsql-exists-warning - :clsql-exists-error - :clsql-closed-error - :clsql-closed-error-database - ;;----------------------------------------------- ;; Symbolic Sql Syntax ;;----------------------------------------------- @@ -306,7 +372,9 @@ :sql-view-class :sql_slot-value -)) + . + #1# + )) (:documentation "This is the INTERNAL SQL-Interface package of USQL.")) @@ -318,10 +386,34 @@ (defpackage #:clsql-usql (:nicknames #:usql #:sql) (:use :common-lisp) - (:import-from :clsql-usql-sys . #1#) - (:export . #1#) + (:import-from :clsql-usql-sys . #2#) + (:export . #2#) (:documentation "This is the SQL-Interface package of USQL.")) + ;; This is from USQL's pcl-patch + #+(or usql-sbcl-pcl usql-cmucl-pcl) + (progn + ;; Note that this will no longer required for cmucl as of version 19a. + (in-package #+cmu :pcl #+sbcl :sb-pcl) + (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) + &body body) + `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) + (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + slot-vars pv-parameters)) + ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) + ,@body)))) + + + #+sbcl + (if (find-package 'sb-mop) + (setq cl:*features* (delete :usql-sbcl-mop cl:*features*)) + (setq cl:*features* (delete :usql-sbcl-pcl cl:*features*))) + + #+cmu + (if (find-package 'mop) + (setq cl:*features* (delete :usql-cmucl-mop cl:*features*)) + (setq cl:*features* (delete :usql-cmucl-pcl cl:*features*))) + );eval-when diff --git a/usql/pcl-patch.lisp b/usql/pcl-patch.lisp deleted file mode 100644 index fd246f8..0000000 --- a/usql/pcl-patch.lisp +++ /dev/null @@ -1,12 +0,0 @@ - -;; Note that this will no longer required for cmucl as of version 19a. - -(in-package #+cmu :pcl #+sbcl :sb-pcl) - -(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) - &body body) - `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) - ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) - ,@body)))