projects
/
clsql.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
cd64aa8
)
r8963: pre 2.6.4
author
Kevin M. Rosenberg
<kevin@rosenberg.net>
Sun, 11 Apr 2004 14:05:44 +0000
(14:05 +0000)
committer
Kevin M. Rosenberg
<kevin@rosenberg.net>
Sun, 11 Apr 2004 14:05:44 +0000
(14:05 +0000)
ChangeLog
patch
|
blob
|
history
base/basic-sql.lisp
patch
|
blob
|
history
base/db-interface.lisp
patch
|
blob
|
history
base/pool.lisp
patch
|
blob
|
history
clsql-base.asd
patch
|
blob
|
history
db-postgresql-socket/postgresql-socket-sql.lisp
patch
|
blob
|
history
db-postgresql/postgresql-sql.lisp
patch
|
blob
|
history
sql/new-objects.lisp
patch
|
blob
|
history
sql/objects.lisp
patch
|
blob
|
history
sql/sql.lisp
patch
|
blob
|
history
tests/test-init.lisp
patch
|
blob
|
history
diff --git
a/ChangeLog
b/ChangeLog
index 5adcac1522f13eda795e94082f0c885ad230e40a..0ef29d1ea432c0611806790d1521dd054cf79427 100644
(file)
--- 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
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 64fdb44038d4741eecb6b5c7ceb27e5768067e66..5c12002bcfe527802991a4d4ebd2ca16629778cb 100644
(file)
--- a/
base/basic-sql.lisp
+++ b/
base/basic-sql.lisp
@@
-60,8
+60,7
@@
pair."))
(values))
(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
(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 4f1dc209ee4eb218d9085cac8854618e4fe3323c..b2ba6e5533a1f20735a017757d517dd85553b7a7 100644
(file)
--- 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)))
(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 53730e3a462a87a267fd4faf99f4b107042f63eb..e051423dced247c09b3cae05e5f46cbfe65d4738 100644
(file)
--- 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)
(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 (,l
ock
) ,@body)
+ #+cmu
(mp:with-lock-held (,l
) ,@body)
+ #+openmcl (ccl:with-lock-grabbed (,l) ,@body)
#+lispworks (mp:with-lock (,l) ,@body)
#+lispworks (mp:with-lock (,l) ,@body)
- #+sb-thread (sb-thread:with-recursive-lock (,l
ock
) ,@body)
+ #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body)
))
#+scl `(thread:with-lock-held (,lock ,desc) ,@body)
))
#+scl `(thread:with-lock-held (,lock ,desc) ,@body)
diff --git
a/clsql-base.asd
b/clsql-base.asd
index 4a13f783b3c0f090659c9c23f7ce1a9dc2a7129b..a870cd0d46721927293fdab4d65d1b2b6d3b5655 100644
(file)
--- 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 "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"))
(: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 2ceb6798bcd83e27d4be61ae761ead66ed08d387..1e29c070d6749dfac59dcc88dde53898c397aff0 100644
(file)
--- 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"
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)
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 5758730e07f19486a79086b364456f3277a8a080..ae3c18ef936cf097ae5325b929ead2a73dbe14a3 100644
(file)
--- 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"
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)
database :auto))
(defun %pg-database-connection (connection-spec)
diff --git
a/sql/new-objects.lisp
b/sql/new-objects.lisp
index c06882fe78fe2cf5decc7f45a5536679d385c7d7..cfd63e173bacb0a2c5240c7f306f2129d93e9206 100644
(file)
--- 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*
(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))))))
(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))
(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)))))
(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
(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))
(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))
(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))
(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))
(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)
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)
(defvar *update-context* nil)
@@
-404,7
+392,6
@@
superclass of the newly-defined View Class."
(setf (slot-value target slot-name)
nil)))))
(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
(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)
(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
(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 3c6588f5540af9aa2e3d2723cac8b87f82ff1fd5..3073bfd17eb916214be19d3421e22dec168a61a8 100644
(file)
--- a/
sql/objects.lisp
+++ b/
sql/objects.lisp
@@
-16,24
+16,19
@@
(in-package #:clsql-sys)
(defclass standard-db-object ()
(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."))
: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)
(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*
(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)))
(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)
(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)))
(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))
(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))
(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)
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)))
(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)))
(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))
(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."))
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
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+)
(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
;; ------------------------------------------------------------
;; Logic for 'faulting in' :join slots
-(defun fault-join-slot-raw (class instance slot-def)
+(defun fault-join-slot-raw (class instance
x
slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
(jc (gethash :join-class dbi)))
(let ((jq (join-qualifier class instance 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)))))
((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)))
(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)
(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)
(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
(t fk))
(typecase hk
(symbol
- (slot-value
instance
hk))
+ (slot-value
object
hk))
(t
hk)))))
(if (listp home-keys)
(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)
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)))
(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 077e27dd365bcd7e79aea520667c3b29be4693f9..a904c89ba7af437459d289932cc3f3c4bb6fda18 100644
(file)
--- a/
sql/sql.lisp
+++ b/
sql/sql.lisp
@@
-255,6
+255,12
@@
condition is true."
(write-char #\) *sql-stream*)))
t)
(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))))
#+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 0f4180ab4d3d301a459e8f2bc57ac78851f5e017..ae0c6b4bf26bdc954b8dc81c70e6f65c31d450e0 100644
(file)
--- a/
tests/test-init.lisp
+++ b/
tests/test-init.lisp
@@
-7,6
+7,11
@@
;;;;
;;;; Initialisation utilities for running regression tests on CLSQL.
;;;;
;;;;
;;;; 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)
;;;; ======================================================================
(in-package #:clsql-tests)
@@
-124,12
+129,6
@@
:make-default t
:if-exists :old))
: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)
(defparameter company1 nil)
(defparameter employee1 nil)
(defparameter employee2 nil)
@@
-144,9
+143,8
@@
(defun test-initialise-database ()
;; Create the tables for our view classes
(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)
(clsql:create-view-from-class 'employee)
(clsql:create-view-from-class 'company)