From 6c70be35cc348b559d8aa869ecd0e14e27d5edbc Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 11 Apr 2004 14:05:44 +0000 Subject: [PATCH] r8963: pre 2.6.4 --- ChangeLog | 9 ++++ base/basic-sql.lisp | 3 +- base/db-interface.lisp | 4 ++ base/pool.lisp | 6 +-- clsql-base.asd | 2 +- .../postgresql-socket-sql.lisp | 7 +-- db-postgresql/postgresql-sql.lisp | 7 +-- sql/new-objects.lisp | 28 +++-------- sql/objects.lisp | 46 +++++++------------ sql/sql.lisp | 6 +++ tests/test-init.lisp | 16 +++---- 11 files changed, 56 insertions(+), 78 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5adcac1..0ef29d1 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.4 + * test/test-init.lisp: Properly handle object + creation. Close database after use. + * sql/sql.lisp: Make DESCRIBE-TABLE a generic + function so can have methods specialized on + table being a string or an sql-table object. + * base/pool.lisp: Really CMUCL locking + 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.6.3 * test/test-init.lisp: Signal correctly diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp index 64fdb44..5c12002 100644 --- a/base/basic-sql.lisp +++ b/base/basic-sql.lisp @@ -60,8 +60,7 @@ pair.")) (values)) -(defun describe-table (table &key (database *default-database*)) - "Return list of 2-element lists containing table name and type." +(defmethod describe-table ((table string) &key (database *default-database*)) (database-describe-table database table)) (defmacro do-query (((&rest args) query-expression diff --git a/base/db-interface.lisp b/base/db-interface.lisp index 4f1dc20..b2ba6e5 100644 --- a/base/db-interface.lisp +++ b/base/db-interface.lisp @@ -254,3 +254,7 @@ the given lisp type and parameters.")) (defmethod database-abort-transaction :before ((database database)) (unless (is-database-open database) (signal-closed-database-error database))) + +(defgeneric describe-table (table &key database) + (:documentation "Describes a table, returns a list of name/type for columns in table")) + diff --git a/base/pool.lisp b/base/pool.lisp index 53730e3..e051423 100644 --- a/base/pool.lisp +++ b/base/pool.lisp @@ -35,10 +35,10 @@ (let ((l (gensym))) `(let ((,l ,lock)) #+allegro (mp:with-process-lock (,l) ,@body) - #+cmu `(mp:with-lock-held (,lock) ,@body) - #+openmcl (ccl:with-lock-grabbed (,lock) ,@body) + #+cmu (mp:with-lock-held (,l) ,@body) + #+openmcl (ccl:with-lock-grabbed (,l) ,@body) #+lispworks (mp:with-lock (,l) ,@body) - #+sb-thread (sb-thread:with-recursive-lock (,lock) ,@body) + #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body) )) #+scl `(thread:with-lock-held (,lock ,desc) ,@body) diff --git a/clsql-base.asd b/clsql-base.asd index 4a13f78..a870cd0 100644 --- a/clsql-base.asd +++ b/clsql-base.asd @@ -38,7 +38,7 @@ (:file "package") (:file "utils" :depends-on ("package")) (:file "classes" :depends-on ("package")) - (:file "conditions" :depends-on ("classes")) + (:file "conditions" :depends-on ("classes" "utils")) (:file "db-interface" :depends-on ("conditions")) (:file "initialize" :depends-on ("db-interface")) (:file "loop-extension" :depends-on ("db-interface")) diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 2ceb679..1e29c07 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -467,12 +467,7 @@ doesn't depend on UFFI." and a.attnum > 0 and a.attrelid = c.oid and a.atttypid = t.oid" - (sql-escape (string-downcase - (etypecase table - (string table) - (clsql-base-sys::sql-create-table - (symbol-name - (slot-value table 'clsql-base-sys::name))))))) + (sql-escape (string-downcase table))) database :auto)) (when (clsql-base-sys:database-type-library-loaded :postgresql-socket) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index 5758730..ae3c18e 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -536,12 +536,7 @@ and a.attnum > 0 and a.attrelid = c.oid and a.atttypid = t.oid" - (sql-escape (string-downcase - (etypecase table - (string table) - (clsql-base-sys::sql-create-table - (symbol-name - (slot-value table 'clsql-base-sys::name))))))) + (sql-escape (string-downcase table))) database :auto)) (defun %pg-database-connection (connection-spec) diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp index c06882f..cfd63e1 100644 --- a/sql/new-objects.lisp +++ b/sql/new-objects.lisp @@ -28,14 +28,15 @@ (defmethod slot-value-using-class ((class standard-db-class) instance slot-def) (declare (optimize (speed 3))) (unless *db-deserializing* - (let ((slot-name (slot-definition-name slot-def)) - (slot-kind (view-class-slot-db-kind slot-def))) + (let* ((slot-name (%svuc-slot-name slot-def)) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) (when (and (eql slot-kind :join) (not (slot-boundp instance slot-name))) (let ((*db-deserializing* t)) (setf (slot-value instance slot-name) (fault-join-slot class instance slot-def)))))) - (call-next-method)) + (call-next-method)) (defmethod (setf slot-value-using-class) :around (new-value (class standard-db-class) instance slot-def) (declare (ignore new-value)) @@ -87,8 +88,6 @@ (database-output-sql keylist database))))) - - (defun create-view-from-class (view-class-name &key (database *default-database*)) "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines @@ -97,9 +96,7 @@ the view. The argument DATABASE has a default value of (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%install-class tclass database) - #+noschema (ensure-schema-version-table database) - #+noschema (update-schema-version-records view-class-name :database database)) + (%install-class tclass database)) (error "Class ~s not found." view-class-name))) (values)) @@ -130,10 +127,7 @@ which defines that view. The argument DATABASE has a default value of (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%uninstall-class tclass) - #+nil - (delete-records :from [clsql_object_v] - :where [= [name] (sql-escape view-class-name)])) + (%uninstall-class tclass)) (error "Class ~s not found." view-class-name))) (values)) @@ -257,13 +251,7 @@ superclass of the newly-defined View Class." list)) (defun slot-type (slotdef) - (specified-type slotdef) - #+ignore - (let ((slot-type (specified-type slotdef))) - (if (listp slot-type) - (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys) - (cdr slot-type)) - (find-symbol (symbol-name slot-type) :clsql-sys)))) + (specified-type slotdef)) (defvar *update-context* nil) @@ -404,7 +392,6 @@ superclass of the newly-defined View Class." (setf (slot-value target slot-name) nil))))) - (defgeneric update-record-from-slot (object slot &key database) (:documentation "The generic function UPDATE-RECORD-FROM-SLOT updates an individual @@ -474,7 +461,6 @@ names are derived from the view class definition.")) (error "Unable to update records")))) t) - (defgeneric update-records-from-instance (object &key database) (:documentation "Using an instance of a view class, update the database table that diff --git a/sql/objects.lisp b/sql/objects.lisp index 3c6588f..3073bfd 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -16,24 +16,19 @@ (in-package #:clsql-sys) (defclass standard-db-object () - ((view-database - :initform nil - :initarg :view-database + ((view-database :initform nil :initarg :view-database :reader view-database :db-kind :virtual)) (:metaclass standard-db-class) (:documentation "Superclass for all CLSQL View Classes.")) -(defmethod view-database ((self standard-db-object)) - (slot-value self 'view-database)) - (defvar *db-deserializing* nil) (defvar *db-initializing* nil) -(defmethod slot-value-using-class ((class standard-db-class) instance slot) +(defmethod slot-value-using-class ((class standard-db-class) instance slot-def) (declare (optimize (speed 3))) (unless *db-deserializing* - (let* ((slot-name (%svuc-slot-name slot)) - (slot-object (%svuc-slot-object slot class)) + (let* ((slot-name (%svuc-slot-name slot-def)) + (slot-object (%svuc-slot-object slot-def class)) (slot-kind (view-class-slot-db-kind slot-object))) (when (and (eql slot-kind :join) (not (slot-boundp instance slot-name))) @@ -50,8 +45,7 @@ (call-next-method)) (defmethod initialize-instance :around ((class standard-db-object) - &rest all-keys - &key &allow-other-keys) + &rest all-keys &key &allow-other-keys) (declare (ignore all-keys)) (let ((*db-deserializing* t)) (call-next-method))) @@ -125,9 +119,7 @@ which defines that view. The argument DATABASE has a default value of (let ((tclass (find-class view-class-name))) (if tclass (let ((*default-database* database)) - (%uninstall-class tclass) - (delete-records :from [clsql_object_v] - :where [= [name] (sql-escape view-class-name)])) + (%uninstall-class tclass)) (error "Class ~s not found." view-class-name))) (values)) @@ -251,11 +243,7 @@ superclass of the newly-defined View Class." list)) (defun slot-type (slotdef) - (let ((slot-type (specified-type slotdef))) - (if (listp slot-type) - (cons (find-symbol (symbol-name (car slot-type)) :clsql-sys) - (cdr slot-type)) - (find-symbol (symbol-name slot-type) :clsql-sys)))) + (specified-type slotdef)) (defmethod update-slot-from-db ((instance standard-db-object) slotdef value) (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) @@ -526,9 +514,6 @@ associated with that database.")) (setf (slot-value obj 'view-database) database)) (values))) -;; Perhaps the slot class is not correct in all CLOS implementations, -;; tho I have not run across a problem yet. - (defmethod handle-cascade-delete-rule ((instance standard-db-object) (slot view-class-effective-slot-definition)) @@ -666,14 +651,14 @@ value. If nulls are allowed for the column, the slot's value will be nil, otherwise its value will be set to the result of calling DATABASE-NULL-VALUE on the type of the slot.")) -(defmethod update-slot-with-null ((instance standard-db-object) +(defmethod update-slot-with-null ((object standard-db-object) slotname slotdef) (let ((st (slot-type slotdef)) (allowed (slot-value slotdef 'nulls-ok))) (if allowed - (setf (slot-value instance slotname) nil) - (setf (slot-value instance slotname) + (setf (slot-value object slotname) nil) + (setf (slot-value object slotname) (database-null-value st))))) (defvar +no-slot-value+ '+no-slot-value+) @@ -886,7 +871,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) ;; ------------------------------------------------------------ ;; Logic for 'faulting in' :join slots -(defun fault-join-slot-raw (class instance slot-def) +(defun fault-join-slot-raw (class instancex slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) (jc (gethash :join-class dbi))) (let ((jq (join-qualifier class instance slot-def))) @@ -909,7 +894,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) ((and (not ts) (gethash :set dbi)) res))))) -(defun join-qualifier (class instance slot-def) +(defun join-qualifier (class object slot-def) (declare (ignore class)) (let* ((dbi (view-class-slot-db-info slot-def)) (jc (find-class (gethash :join-class dbi))) @@ -918,8 +903,8 @@ DATABASE-NULL-VALUE on the type of the slot.")) (foreign-keys (gethash :foreign-key dbi)) (home-keys (gethash :home-key dbi))) (when (every #'(lambda (slt) - (and (slot-boundp instance slt) - (not (null (slot-value instance slt))))) + (and (slot-boundp object slt) + (not (null (slot-value object slt))))) (if (listp home-keys) home-keys (list home-keys))) (let ((jc (mapcar #'(lambda (hk fk) @@ -934,7 +919,7 @@ DATABASE-NULL-VALUE on the type of the slot.")) (t fk)) (typecase hk (symbol - (slot-value instance hk)) + (slot-value object hk)) (t hk))))) (if (listp home-keys) @@ -1051,6 +1036,7 @@ tuples." target-args)))) (multiple-value-bind (target-args qualifier-args) (query-get-selections select-all-args) + ;; (cmsg "Qual args = ~s" qualifier-args) (if (select-objects target-args) (apply #'find-all target-args qualifier-args) (let ((expr (apply #'make-query select-all-args))) diff --git a/sql/sql.lisp b/sql/sql.lisp index 077e27d..a904c89 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -255,6 +255,12 @@ condition is true." (write-char #\) *sql-stream*))) t) +(defmethod describe-table ((table sql-create-table) + &key (database *default-database*)) + (database-describe-table + database + (string-downcase (symbol-name (slot-value table 'name))))) + #+nil (defmethod add-storage-class ((self database) (class symbol) &key (sequence t)) (let ((tablename (view-table (find-class class)))) diff --git a/tests/test-init.lisp b/tests/test-init.lisp index 0f4180a..ae0c6b4 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -7,6 +7,11 @@ ;;;; ;;;; Initialisation utilities for running regression tests on CLSQL. ;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ====================================================================== (in-package #:clsql-tests) @@ -124,12 +129,6 @@ :make-default t :if-exists :old)) -(defmacro with-ignore-errors (&rest forms) - `(progn - ,@(mapcar - (lambda (x) (list 'ignore-errors x)) - forms))) - (defparameter company1 nil) (defparameter employee1 nil) (defparameter employee2 nil) @@ -144,9 +143,8 @@ (defun test-initialise-database () ;; Create the tables for our view classes - (ignore-errors - (clsql:drop-view-from-class 'employee) - (clsql:drop-view-from-class 'company)) + (ignore-errors (clsql:drop-view-from-class 'employee)) + (ignore-errors (clsql:drop-view-from-class 'company)) (clsql:create-view-from-class 'employee) (clsql:create-view-from-class 'company) -- 2.34.1