;; Support for pooled connections
#:database-type
-
+
;; Large objects (Marc B)
#:database-create-large-object
#:database-write-large-object
#:transaction
#:transaction-level
#:conn-pool
-
+
;; utils.lisp
#:number-to-sql-string
#:float-to-sql-string
#:status ; database xx
#:with-database
#:with-default-database
+ #:disconnect-pooled
;; basic-sql.lisp
#:query
:description "A regression test suite for CLSQL-USQL."
:components
((:module usql-tests
+ :serial t
:components ((:file "package")
(:file "test-init")
(:file "test-connection")
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")
: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))))))
#: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
;;;; ======================================================================
-(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
-
(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])
(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)
;;;;
;;;; ======================================================================
-(in-package :clsql-usql-tests)
+(in-package #:clsql-usql-tests)
(defvar *test-database-type* nil)
(defvar *test-database-server* "")
: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"))
: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"))
: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"))
: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"))
: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"))
: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"))
: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"))
: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"))
: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"))
: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"))
"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))
(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'"))
(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)
;;;;
;;;; ======================================================================
-(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")
--- /dev/null
+;;;; -*- 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))
+ )
+
;;;;
;;;; ======================================================================
-(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*)))
;; ------------------------------------------------------------
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)
(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
())
(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))
;; 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)))
(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*))
+ )
(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
"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))
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; ======================================================================
;;;; File: package.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>, Kevin Rosenberg
;;;; Created: 30/03/2004
;;;; Updated: <04/04/2004 12:21:50 marcusp>
;;;; ======================================================================
(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
;; I = Implemented, D = Documented
;; name file ID
;;====================================================
- #1=(;;------------------------------------------------
+ #2=(;;------------------------------------------------
;; CommonSQL API
;;------------------------------------------------
;;FDML
: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
;;-----------------------------------------------
:sql-view-class
:sql_slot-value
-))
+ .
+ #1#
+ ))
(:documentation "This is the INTERNAL SQL-Interface package of USQL."))
(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
+++ /dev/null
-
-;; 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)))