From: Kevin M. Rosenberg Date: Sun, 11 Apr 2004 10:40:30 +0000 (+0000) Subject: r8946: merge done except for changes in objects file X-Git-Tag: v3.8.6~671 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=e3f355aa2b125569097bd7108fbbd14daa23e7aa r8946: merge done except for changes in objects file --- diff --git a/ChangeLog b/ChangeLog index ebc1347..9edc43b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,7 +1,25 @@ +10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) + * Version 2.6.2: New CLSQL API functions: + DESCRIBE-TABLE AND TRUNCATE-DATABASE + Currently, this are only supported on :postgresql + and :postgresql-socket + * base/database.lisp: automatically load ASDF system + in CONNECT if not already loaded + * base/tests.lisp: disconnect database after testing + * base/*.lisp: Remove CLOSED-DATABASE type in favor + of storing open/closed status in slot of database + * base/pool.lisp: Support locks for CMUCL, OpenMCL, SBCL + * db-postgresql/postgresql-sql.lisp: add DATABASE-RECONNECT, + DATABASE-DESCRIBE-TABLE + * db-sqlite/sqlite-sql.lisp: Add missing slots in database + * base/conditions: Remove duplicate condition + * db-*/*-sql.lisp: Fill new database slot DATABASE-TYPE + * base/recording.lisp: Add new :QUERY type for recording + 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.6.1: documentation fixes, merged classic-tests into tests - + 10 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.6.0 released: New API functions CREATE-DATABASE, DESTORY-DATABASE, PROBE-DATABASE diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index af8e461..34e6c69 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -37,7 +37,7 @@ ;; ------------------------------------------------------------ ;; metaclass: view-class -(defclass standard-db-class (standard-class) +(defclass view-metaclass (standard-class) ((view-table :accessor view-table :initarg :view-table) @@ -91,7 +91,7 @@ #+lispworks (defmethod clos::canonicalize-defclass-slot :around - ((prototype standard-db-class) slot) + ((prototype view-metaclass) slot) "\\lw\\ signals an error on unknown slot options; so this method removes any extra allowed options before calling the default method and returns the canonicalized extra options concatenated to the result @@ -121,7 +121,7 @@ of the default method. The extra allowed options are the value of the #+lispworks (defmethod clos::canonicalize-class-options :around - ((prototype standard-db-class) class-options) + ((prototype view-metaclass) class-options) "\\lw\\ signals an error on unknown class options; so this method removes any extra allowed options before calling the default method and returns the canonicalized extra options concatenated to the result @@ -145,7 +145,7 @@ of the default method. The extra allowed options are the value of the result)) -(defmethod validate-superclass ((class standard-db-class) +(defmethod validate-superclass ((class view-metaclass) (superclass standard-class)) t) @@ -178,13 +178,13 @@ of the default method. The extra allowed options are the value of the (pop-arg mylist)) newlist)) -(defmethod initialize-instance :around ((class standard-db-class) +(defmethod initialize-instance :around ((class view-metaclass) &rest all-keys &key direct-superclasses base-table schemas version qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) - (vmc (find-class 'standard-db-class))) + (vmc (find-class 'view-metaclass))) (setf (view-class-qualifier class) (car qualifier)) (if root-class @@ -210,13 +210,13 @@ of the default method. The extra allowed options are the value of the (register-metaclass class (nth (1+ (position :direct-slots all-keys)) all-keys)))) -(defmethod reinitialize-instance :around ((class standard-db-class) +(defmethod reinitialize-instance :around ((class view-metaclass) &rest all-keys &key base-table schemas version direct-superclasses qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) - (vmc (find-class 'standard-db-class))) + (vmc (find-class 'view-metaclass))) (setf (view-table class) (table-name-from-arg (sql-escape (or (and base-table (if (listp base-table) @@ -284,9 +284,9 @@ of the default method. The extra allowed options are the value of the (ordered-class-slots class))))) #+(or allegro openmcl) -(defmethod finalize-inheritance :after ((class standard-db-class)) +(defmethod finalize-inheritance :after ((class view-metaclass)) ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false - ;; for standard-db-class + ;; for view-metaclass #+openmcl (mapcar #'(lambda (s) @@ -437,13 +437,13 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") standard-effective-slot-definition) ()) -(defmethod direct-slot-definition-class ((class standard-db-class) +(defmethod direct-slot-definition-class ((class view-metaclass) #+kmr-normal-dsdc &rest initargs) (declare (ignore initargs)) (find-class 'view-class-direct-slot-definition)) -(defmethod effective-slot-definition-class ((class standard-db-class) +(defmethod effective-slot-definition-class ((class view-metaclass) #+kmr-normal-esdc &rest initargs) (declare (ignore initargs)) @@ -455,7 +455,7 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (class-precedence-list class)) #-(or sbcl cmu) -(defmethod compute-slots ((class standard-db-class)) +(defmethod compute-slots ((class view-metaclass)) "Need to sort order of class slots so they are the same across implementations." (let ((slots (call-next-method)) @@ -506,7 +506,7 @@ which does type checking before storing a value in a slot." ;; what kind of database value (if any) is stored there, generates and ;; verifies the column name. -(defmethod compute-effective-slot-definition ((class standard-db-class) +(defmethod compute-effective-slot-definition ((class view-metaclass) #+kmr-normal-cesd slot-name direct-slots) #+kmr-normal-cesd (declare (ignore slot-name)) diff --git a/sql/new-objects.lisp b/sql/new-objects.lisp new file mode 100644 index 0000000..e5e0614 --- /dev/null +++ b/sql/new-objects.lisp @@ -0,0 +1,1048 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id: objects.lisp 8906 2004-04-09 12:41:07Z kevin $ +;;;; +;;;; The CLSQL Object Oriented Data Definitional Language (OODDL) +;;;; and Object Oriented Data Manipulation Language (OODML). +;;;; +;;;; 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-sys) + + +;; utils + +(defun replaced-string-length (str repl-alist) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) + (let* ((c (char str i)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) + + +(defun substitute-chars-strings (str repl-alist) + "Replace all instances of a chars with a string. repl-alist is an assoc +list of characters and replacement strings." + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) + +(defun string-replace (procstr match-char subst-str) + "Substitutes a string for a single matching character of a string" + (substitute-chars-strings procstr (list (cons match-char subst-str)))) + + +(defclass standard-db-object () + ((stored :db-kind :virtual + :initarg :stored + :initform nil)) + (:metaclass view-metaclass) + (:documentation "Superclass for all CLSQL View Classes.")) + +(defvar *deserializing* nil) +(defvar *initializing* nil) + +(defmethod initialize-instance :around ((object standard-db-object) + &rest all-keys &key &allow-other-keys) + (declare (ignore all-keys)) + (let ((*initializing* t)) + (call-next-method) + (unless *deserializing* + #+nil (created-object object) + (update-records-from-instance object)))) + +(defmethod slot-value-using-class ((class view-metaclass) instance slot-def) + (declare (optimize (speed 3))) + (unless *deserializing* + (let ((slot-name (%slot-def-name slot-def)) + (slot-kind (view-class-slot-db-kind slot-def))) + (when (and (eql slot-kind :join) + (not (slot-boundp instance slot-name))) + (let ((*deserializing* t)) + (setf (slot-value instance slot-name) + (fault-join-slot class instance slot-def)))))) + (call-next-method)) + +(defmethod (setf slot-value-using-class) :around (new-value (class view-metaclass) instance slot-def) + (declare (ignore new-value)) + (let* ((slot-name (%slot-def-name slot-def)) + (slot-kind (view-class-slot-db-kind slot-def)) + (no-update? (or (eql slot-kind :virtual) + *initializing* + *deserializing*))) + (call-next-method) + (unless no-update? + (update-record-from-slot instance slot-name)))) + +(defun %slot-def-name (slot) + #+lispworks slot + #-lispworks (slot-definition-name slot)) + +(defun %slot-object (slot class) + (declare (ignorable class)) + #+lispworks (clos:find-slot-definition slot class) + #-lispworks slot) + +(defun sequence-from-class (view-class-name) + (sql-escape + (concatenate + 'string + (symbol-name (view-table (find-class view-class-name))) + "-SEQ"))) + +(defun create-sequence-from-class (view-class-name + &key (database *default-database*)) + (create-sequence (sequence-from-class view-class-name) :database database)) + +(defun drop-sequence-from-class (view-class-name + &key (if-does-not-exist :error) + (database *default-database*)) + (drop-sequence (sequence-from-class view-class-name) + :if-does-not-exist if-does-not-exist + :database database)) + +;; +;; Build the database tables required to store the given view class +;; + +(defmethod database-pkey-constraint ((class view-metaclass) database) + (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) + (when keylist + (format nil "CONSTRAINT ~APK PRIMARY KEY~A" + (database-output-sql (view-table class) database) + (database-output-sql keylist database))))) + + + +#+noschema +(progn +#.(locally-enable-sql-reader-syntax) + +(defun ensure-schema-version-table (database) + (unless (table-exists-p "clsql_object_v" :database database) + (create-table [clsql_object_v] '(([name] string) + ([vers] integer) + ([def] string)) + :database database))) + +(defun update-schema-version-records (view-class-name + &key (database *default-database*)) + (let ((schemadef nil) + (tclass (find-class view-class-name))) + (dolist (slotdef (class-slots tclass)) + (let ((res (database-generate-column-definition view-class-name + slotdef database))) + (when res (setf schemadef (cons res schemadef))))) + (when schemadef + (delete-records :from [clsql_object_v] + :where [= [name] (sql-escape (class-name tclass))] + :database database) + (insert-records :into [clsql_object_v] + :av-pairs `(([name] ,(sql-escape (class-name tclass))) + ([vers] ,(car (object-version tclass))) + ([def] ,(prin1-to-string + (object-definition tclass)))) + :database database)))) + +#.(restore-sql-reader-syntax-state) +) + +(defun create-view-from-class (view-class-name + &key (database *default-database*)) + "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines +the view. The argument DATABASE has a default value of +*DEFAULT-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)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defmethod %install-class ((self view-metaclass) database &aux schemadef) + (dolist (slotdef (ordered-class-slots self)) + (let ((res (database-generate-column-definition (class-name self) + slotdef database))) + (when res + (push res schemadef)))) + (unless schemadef + (error "Class ~s has no :base slots" self)) + (create-table (sql-expression :table (view-table self)) schemadef + :database database + :constraints (database-pkey-constraint self database)) + (push self (database-view-classes database)) + t) + +;; +;; Drop the tables which store the given view class +;; + +#.(locally-enable-sql-reader-syntax) + +(defun drop-view-from-class (view-class-name &key (database *default-database*)) + "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME +which defines that view. The argument DATABASE has a default value of +*DEFAULT-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)])) + (error "Class ~s not found." view-class-name))) + (values)) + +#.(restore-sql-reader-syntax-state) + +(defun %uninstall-class (self &key (database *default-database*)) + (drop-table (sql-expression :table (view-table self)) + :if-does-not-exist :ignore + :database database) + (setf (database-view-classes database) + (remove self (database-view-classes database)))) + + +;; +;; List all known view classes +;; + +(defun list-classes (&key (test #'identity) + (root-class 'standard-db-object) + (database *default-database*)) + "Returns a list of View Classes connected to a given DATABASE which +defaults to *DEFAULT-DATABASE*." + (declare (ignore root-class)) + (remove-if #'(lambda (c) (not (funcall test c))) + (database-view-classes database))) + +;; +;; Define a new view class +;; + +(defmacro def-view-class (class supers slots &rest options) + "Extends the syntax of defclass to allow special slots to be mapped +onto the attributes of database views. The macro DEF-VIEW-CLASS +creates a class called CLASS which maps onto a database view. Such a +class is called a View Class. The macro DEF-VIEW-CLASS extends the +syntax of DEFCLASS to allow special base slots to be mapped onto the +attributes of database views (presently single tables). When a select +query that names a View Class is submitted, then the corresponding +database view is queried, and the slots in the resulting View Class +instances are filled with attribute values from the database. If +SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the +superclass of the newly-defined View Class." + `(progn + (defclass ,class ,supers ,slots ,@options + (:metaclass view-metaclass)) + (finalize-inheritance (find-class ',class)))) + +(defun keyslots-for-class (class) + (slot-value class 'key-slots)) + +(defun key-qualifier-for-instance (obj &key (database *default-database*)) + (let ((tb (view-table (class-of obj)))) + (flet ((qfk (k) + (sql-operation '== + (sql-expression :attribute + (view-class-slot-column k) + :table tb) + (db-value-from-slot + k + (slot-value obj (slot-definition-name k)) + database)))) + (let* ((keys (keyslots-for-class (class-of obj))) + (keyxprs (mapcar #'qfk (reverse keys)))) + (cond + ((= (length keyxprs) 0) nil) + ((= (length keyxprs) 1) (car keyxprs)) + ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs))))))) + +;; +;; Function used by 'generate-selection-list' +;; + +(defun generate-attribute-reference (vclass slotdef) + (cond + ((eq (view-class-slot-db-kind slotdef) :base) + (sql-expression :attribute (view-class-slot-column slotdef) + :table (view-table vclass))) + ((eq (view-class-slot-db-kind slotdef) :key) + (sql-expression :attribute (view-class-slot-column slotdef) + :table (view-table vclass))) + (t nil))) + +;; +;; Function used by 'find-all' +;; + +(defun generate-selection-list (vclass) + (let ((sels nil)) + (dolist (slotdef (ordered-class-slots vclass)) + (let ((res (generate-attribute-reference vclass slotdef))) + (when res + (push (cons slotdef res) sels)))) + (if sels + sels + (error "No slots of type :base in view-class ~A" (class-name vclass))))) + +;; +;; Used by 'create-view-from-class' +;; + + +(defmethod database-generate-column-definition (class slotdef database) + (declare (ignore database class)) + (when (member (view-class-slot-db-kind slotdef) '(:base :key)) + (let ((cdef + (list (sql-expression :attribute (view-class-slot-column slotdef)) + (slot-type slotdef)))) + (let ((const (view-class-slot-db-constraints slotdef))) + (when const + (setq cdef (append cdef (list const))))) + cdef))) + +;; +;; Called by 'get-slot-values-from-view' +;; + +(declaim (inline delistify)) +(defun delistify (list) + (if (listp list) + (car list) + 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)))) + +(defvar *update-context* nil) + +(defmethod update-slot-from-db ((instance standard-db-object) slotdef value) + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let* ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-name (slot-definition-name slotdef)) + (slot-type (slot-type slotdef)) + (*update-context* (cons (type-of instance) slot-name))) + (cond ((and value (null slot-reader)) + (setf (slot-value instance slot-name) + (read-sql-value value (delistify slot-type) + *default-database*))) + ((null value) + (update-slot-with-null instance slot-name slotdef)) + ((typep slot-reader 'string) + (setf (slot-value instance slot-name) + (format nil slot-reader value))) + ((typep slot-reader 'function) + (setf (slot-value instance slot-name) + (apply slot-reader (list value)))) + (t + (error "Slot reader is of an unusual type."))))) + +(defmethod key-value-from-db (slotdef value database) + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-type (slot-type slotdef))) + (cond ((and value (null slot-reader)) + (read-sql-value value (delistify slot-type) database)) + ((null value) + nil) + ((typep slot-reader 'string) + (format nil slot-reader value)) + ((typep slot-reader 'function) + (apply slot-reader (list value))) + (t + (error "Slot reader is of an unusual type."))))) + +(defun db-value-from-slot (slotdef val database) + (let ((dbwriter (view-class-slot-db-writer slotdef)) + (dbtype (slot-type slotdef))) + (typecase dbwriter + (string (format nil dbwriter val)) + (function (apply dbwriter (list val))) + (t + (typecase dbtype + (cons + (database-output-sql-as-type (car dbtype) val database)) + (t + (database-output-sql-as-type dbtype val database))))))) + +(defun check-slot-type (slotdef val) + (let* ((slot-type (slot-type slotdef)) + (basetype (if (listp slot-type) (car slot-type) slot-type))) + (when (and slot-type val) + (unless (typep val basetype) + (error 'clsql-type-error + :slotname (slot-definition-name slotdef) + :typespec slot-type + :value val))))) + +;; +;; Called by find-all +;; + +(defmethod get-slot-values-from-view (obj slotdeflist values) + (flet ((update-slot (slot-def values) + (update-slot-from-db obj slot-def values))) + (mapc #'update-slot slotdeflist values) + obj)) + +(defun synchronize-keys (src srckey dest destkey) + (let ((skeys (if (listp srckey) srckey (list srckey))) + (dkeys (if (listp destkey) destkey (list destkey)))) + (mapcar #'(lambda (sk dk) + (setf (slot-value dest dk) + (typecase sk + (symbol + (slot-value src sk)) + (t sk)))) + skeys dkeys))) + +(defun desynchronize-keys (dest destkey) + (let ((dkeys (if (listp destkey) destkey (list destkey)))) + (mapcar #'(lambda (dk) + (setf (slot-value dest dk) nil)) + dkeys))) + +(defmethod add-to-relation ((target standard-db-object) + slot-name + (value standard-db-object)) + (let* ((objclass (class-of target)) + (sdef (or (slotdef-for-slot-with-class slot-name objclass) + (error "~s is not an known slot on ~s" slot-name target))) + (dbinfo (view-class-slot-db-info sdef)) + (join-class (gethash :join-class dbinfo)) + (homekey (gethash :home-key dbinfo)) + (foreignkey (gethash :foreign-key dbinfo)) + (to-many (gethash :set dbinfo))) + (unless (equal (type-of value) join-class) + (error 'clsql-type-error :slotname slot-name :typespec join-class + :value value)) + (when (gethash :target-slot dbinfo) + (error "add-to-relation does not work with many-to-many relations yet.")) + (if to-many + (progn + (synchronize-keys target homekey value foreignkey) + (if (slot-boundp target slot-name) + (unless (member value (slot-value target slot-name)) + (setf (slot-value target slot-name) + (append (slot-value target slot-name) (list value)))) + (setf (slot-value target slot-name) (list value)))) + (progn + (synchronize-keys value foreignkey target homekey) + (setf (slot-value target slot-name) value))))) + +(defmethod remove-from-relation ((target standard-db-object) + slot-name (value standard-db-object)) + (let* ((objclass (class-of target)) + (sdef (slotdef-for-slot-with-class slot-name objclass)) + (dbinfo (view-class-slot-db-info sdef)) + (homekey (gethash :home-key dbinfo)) + (foreignkey (gethash :foreign-key dbinfo)) + (to-many (gethash :set dbinfo))) + (when (gethash :target-slot dbinfo) + (error "remove-relation does not work with many-to-many relations yet.")) + (if to-many + (progn + (desynchronize-keys value foreignkey) + (if (slot-boundp target slot-name) + (setf (slot-value target slot-name) + (remove value + (slot-value target slot-name) + :test #'equal)))) + (progn + (desynchronize-keys target homekey) + (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 +data item in the column represented by SLOT. The DATABASE is only used +if OBJECT is not yet associated with any database, in which case a +record is created in DATABASE. Only SLOT is initialized in this case; +other columns in the underlying database receive default values. The +argument SLOT is the CLOS slot name; the corresponding column names +are derived from the View Class definition.")) + +(defmethod update-record-from-slot ((obj standard-db-object) slot &key + (database *default-database*)) + #+nil (odcl:updated-object obj) + (let* ((vct (view-table (class-of obj))) + (stored? (slot-value obj 'stored)) + (sd (slotdef-for-slot-with-class slot (class-of obj)))) + (check-slot-type sd (slot-value obj slot)) + (let* ((att (view-class-slot-column sd)) + (val (db-value-from-slot sd (slot-value obj slot) database))) + (cond ((and vct sd stored?) + (update-records :table (sql-expression :table vct) + :attributes (list (sql-expression :attribute att)) + :values (list val) + :where (key-qualifier-for-instance obj :database database) + :database database)) + ((not stored?) + t) + (t + (error "Unable to update record"))))) + t) + +(defgeneric update-record-from-slots (object slots &key database) + (:documentation + "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the +columns represented by SLOTS. The DATABASE is only used if OBJECT is +not yet associated with any database, in which case a record is +created in DATABASE. Only slots are initialized in this case; other +columns in the underlying database receive default values. The +argument SLOTS contains the CLOS slot names; the corresponding column +names are derived from the view class definition.")) + +(defmethod update-record-from-slots ((obj standard-db-object) slots &key + (database *default-database*)) + (let* ((vct (view-table (class-of obj))) + (stored? (slot-value obj 'stored)) + (sds (slotdefs-for-slots-with-class slots (class-of obj))) + (avps (mapcar #'(lambda (s) + (let ((val (slot-value + obj (slot-definition-name s)))) + (check-slot-type s val) + (list (sql-expression + :attribute (view-class-slot-column s)) + (db-value-from-slot s val database)))) + sds))) + (cond ((and avps stored?) + (update-records :table (sql-expression :table vct) + :av-pairs avps + :where (key-qualifier-for-instance + obj :database database) + :database database)) + (avps + (insert-records :into (sql-expression :table vct) + :av-pairs avps + :database database) + (setf (slot-value obj 'stored) t)) + (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 +stores its instance data. If the instance is already associated with a +database, that database is used, and database is ignored. If instance +is not yet associated with a database, a record is created for +instance in the appropriate table of database and the instance becomes +associated with that database.")) + +(defmethod update-records-from-instance ((obj standard-db-object) + &key (database *default-database*)) + (labels ((slot-storedp (slot) + (and (member (view-class-slot-db-kind slot) '(:base :key)) + (slot-boundp obj (slot-definition-name slot)))) + (slot-value-list (slot) + (let ((value (slot-value obj (slot-definition-name slot)))) + (check-slot-type slot value) + (list (sql-expression :attribute (view-class-slot-column slot)) + (db-value-from-slot slot value database))))) + (let* ((view-class (class-of obj)) + (view-class-table (view-table view-class)) + (slots (remove-if-not #'slot-storedp (class-slots view-class))) + (record-values (mapcar #'slot-value-list slots))) + (unless record-values + (error "No settable slots.")) + (if (slot-value obj 'stored) + (update-records :table (sql-expression :table view-class-table) + :av-pairs record-values + :where (key-qualifier-for-instance + obj :database database) + :database database) + (progn + (insert-records :into (sql-expression :table view-class-table) + :av-pairs record-values + :database database) + (setf (slot-value obj 'stored) t))))) + t) + + (setf (symbol-function (intern (symbol-name '#:store-instance))) + (symbol-function 'update-records-from-instance)) + +(defmethod delete-instance-records ((object standard-db-object)) + (let ((vt (sql-expression :table (view-table (class-of object)))) + (qualifier (key-qualifier-for-instance object :database *default-database*))) + (delete-records :from vt :where qualifier :database *default-database*) + #+ignore (odcl::deleted-object object))) + +(defgeneric update-instance-from-db (instance) + (:documentation + "Updates the values in the slots of the View Class instance +INSTANCE using the data in the database DATABASE which defaults to the +database that INSTANCE is associated with, or the value of +*DEFAULT-DATABASE*.")) + +(defmethod update-instance-from-db ((object standard-db-object)) + (let* ((view-class (find-class (class-name (class-of object)))) + (view-table (sql-expression :table (view-table view-class))) + (view-qual (key-qualifier-for-instance object :database *default-database*)) + (sels (generate-selection-list view-class)) + (res (apply #'select (append (mapcar #'cdr sels) (list :from view-table + :where view-qual))))) + (when res + (get-slot-values-from-view object (mapcar #'car sels) (car res)) + res))) + + +(defgeneric database-null-value (type) + (:documentation "Return an expression of type TYPE which SQL NULL values +will be converted into.")) + +(defmethod database-null-value ((type t)) + (cond + ((subtypep type 'string) nil) + ((subtypep type 'integer) nil) + ((subtypep type 'list) nil) + ((subtypep type 'boolean) nil) + ((eql type t) nil) + ((subtypep type 'symbol) nil) + ((subtypep type 'keyword) nil) + ((subtypep type 'wall-time) nil) + ((subtypep type 'duration) nil) + ((subtypep type 'money) nil) + (t + (error "Unable to handle null for type ~A" type)))) + +(defgeneric update-slot-with-null (instance slotname slotdef) + (:documentation "Called to update a slot when its column has a NULL +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 ((object standard-db-object) + slotname + slotdef) + (let ((st (slot-definition-type slotdef)) + (allowed (slot-value slotdef 'nulls-ok))) + (if allowed + (setf (slot-value object slotname) nil) + (setf (slot-value object slotname) + (database-null-value st))))) + +(defvar +no-slot-value+ '+no-slot-value+) + +(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*)) + (let* ((class (find-class classname)) + (sld (slotdef-for-slot-with-class slot class))) + (if sld + (if (eq value +no-slot-value+) + (sql-expression :attribute (view-class-slot-column sld) + :table (view-table class)) + (db-value-from-slot + sld + value + database)) + (error "Unknown slot ~A for class ~A" slot classname)))) + +(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) + (declare (ignore database)) + (let* ((class (find-class classname))) + (unless (view-table class) + (error "No view-table for class ~A" classname)) + (sql-expression :table (view-table class)))) + +(defmethod database-get-type-specifier (type args database) + (declare (ignore type args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)")) + +(defmethod database-get-type-specifier ((type (eql 'integer)) args database) + (declare (ignore database)) + ;;"INT8") + (if args + (format nil "INT(~A)" (car args)) + "INT")) + +(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args + database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'simple-string)) args + database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'string)) args database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) + (declare (ignore args)) + (case (database-type database) + (:postgresql + "TIMESTAMP WITHOUT TIME ZONE") + (:postgresql-socket + "TIMESTAMP WITHOUT TIME ZONE") + (:mysql + "DATETIME") + (t "TIMESTAMP"))) + +(defmethod database-get-type-specifier ((type (eql 'duration)) args database) + (declare (ignore database args)) + "VARCHAR") + +(defmethod database-get-type-specifier ((type (eql 'money)) args database) + (declare (ignore database args)) + "INT8") + +(deftype raw-string (&optional len) + "A string which is not trimmed when retrieved from the database" + `(string ,len)) + +(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + "VARCHAR")) + +(defmethod database-get-type-specifier ((type (eql 'float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 't)) args database) + (declare (ignore args database)) + "BOOL") + +(defmethod database-output-sql-as-type (type val database) + (declare (ignore type database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'list)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (let ((escaped (prin1-to-string val))) + (setf escaped (string-replace #\Null " " escaped)) + escaped))) + + +(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) + (declare (ignore database)) + (if val + (symbol-name val)) + "") + +(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) + (declare (ignore database)) + (if val + (symbol-name val) + "")) + +(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'array)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 't)) val database) + (declare (ignore database)) + (if val "t" "f")) + +(defmethod database-output-sql-as-type ((type (eql 'string)) val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-string)) + val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) + val database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val type database) + (declare (ignore type database)) + (read-from-string val)) + +(defmethod read-sql-value (val (type (eql 'string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'raw-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'keyword)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (intern (string-upcase val) "KEYWORD"))) + +(defmethod read-sql-value (val (type (eql 'symbol)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (unless (string= val "NIL") + (intern (string-upcase val) + (symbol-package *update-context*))))) + +(defmethod read-sql-value (val (type (eql 'integer)) database) + (declare (ignore database)) + (etypecase val + (string + (read-from-string val)) + (number val))) + +(defmethod read-sql-value (val (type (eql 'float)) database) + (declare (ignore database)) + ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) + (float (read-from-string val))) + +(defmethod read-sql-value (val (type (eql 't)) database) + (declare (ignore database)) + (equal "t" val)) + +(defmethod read-sql-value (val (type (eql 'wall-time)) database) + (declare (ignore database)) + (unless (eq 'NULL val) + (parse-timestring val))) + +(defmethod read-sql-value (val (type (eql 'duration)) database) + (declare (ignore database)) + (unless (or (eq 'NULL val) + (equal "NIL" val)) + (parse-timestring val))) + +(defmethod read-sql-value (val (type (eql 'money)) database) + (unless (eq 'NULL val) + (make-instance 'money :units (read-sql-value val 'integer database)))) + +;; ------------------------------------------------------------ +;; Logic for 'faulting in' :join slots + +(defun fault-join-slot-raw (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (jc (gethash :join-class dbi))) + (let ((jq (join-qualifier class object slot-def))) + (when jq + (select jc :where jq))))) + +(defun fault-join-slot (class object slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (res (fault-join-slot-raw class object slot-def))) + (when res + (cond + ((and ts (gethash :set dbi)) + (mapcar (lambda (obj) + (cons obj (slot-value obj ts))) res)) + ((and ts (not (gethash :set dbi))) + (mapcar (lambda (obj) (slot-value obj ts)) res)) + ((and (not ts) (not (gethash :set dbi))) + (car res)) + ((and (not ts) (gethash :set dbi)) + res))))) + +(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))) + ;;(ts (gethash :target-slot dbi)) + ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc))) + (foreign-keys (gethash :foreign-key dbi)) + (home-keys (gethash :home-key dbi))) + (when (every #'(lambda (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) + (let ((fksd (slotdef-for-slot-with-class fk jc))) + (sql-operation '== + (typecase fk + (symbol + (sql-expression + :attribute (view-class-slot-column fksd) + :table (view-table jc))) + (t fk)) + (typecase hk + (symbol + (slot-value object hk)) + (t + hk))))) + (if (listp home-keys) home-keys (list home-keys)) + (if (listp foreign-keys) foreign-keys (list foreign-keys))))) + (when jc + (if (> (length jc) 1) + (apply #'sql-and jc) + jc)))))) + +(defmethod postinitialize ((self t)) + ) + +(defun find-all (view-classes &rest args &key all set-operation distinct from + where group-by having order-by order-by-descending offset limit + (database *default-database*)) + "tweeze me apart someone pleeze" + (declare (ignore all set-operation group-by having + offset limit) + (optimize (debug 3) (speed 1))) + ;; (cmsg "Args = ~s" args) + (remf args :from) + (let* ((*deserializing* t) + (*default-database* (or database + (error 'usql-nodb-error)))) + (flet ((table-sql-expr (table) + (sql-expression :table (view-table table))) + (ref-equal (ref1 ref2) + (equal (sql ref1) + (sql ref2))) + (tables-equal (table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name))))) + + (let* ((sclasses (mapcar #'find-class view-classes)) + (sels (mapcar #'generate-selection-list sclasses)) + (fullsels (apply #'append sels)) + (sel-tables (collect-table-refs where)) + (tables (remove-duplicates (append (mapcar #'table-sql-expr sclasses) sel-tables) + :test #'tables-equal)) + (res nil)) + (dolist (ob (listify order-by)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (dolist (ob (listify order-by-descending)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (dolist (ob (listify distinct)) + (when (and (typep ob 'sql-ident) (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + ;; (cmsg "Tables = ~s" tables) + ;; (cmsg "From = ~s" from) + (setq res (apply #'select (append (mapcar #'cdr fullsels) + (cons :from (list (append (when from (listify from)) (listify tables)))) args))) + (flet ((build-object (vals) + (flet ((%build-object (vclass selects) + (let ((class-name (class-name vclass)) + (db-vals (butlast vals (- (list-length vals) + (list-length selects))))) + ;; (setf vals (nthcdr (list-length selects) vals)) + (%make-fresh-object class-name (mapcar #'car selects) db-vals)))) + (let ((objects (mapcar #'%build-object sclasses sels))) + (if (= (length sclasses) 1) + (car objects) + objects))))) + (mapcar #'build-object res)))))) + +(defun %make-fresh-object (class-name slots values) + (let* ((*initializing* t) + (obj (make-instance class-name + :stored t))) + (setf obj (get-slot-values-from-view obj slots values)) + (postinitialize obj) + obj)) + +(defun select (&rest select-all-args) + "Selects data from database given the constraints specified. Returns +a list of lists of record values as specified by select-all-args. By +default, the records are each represented as lists of attribute +values. The selections argument may be either db-identifiers, literal +strings or view classes. If the argument consists solely of view +classes, the return value will be instances of objects rather than raw +tuples." + (flet ((select-objects (target-args) + (and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (find-class arg nil))) + 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))) + (destructuring-bind (&key (flatp nil) + (database *default-database*) + &allow-other-keys) + qualifier-args + (let ((res (query expr :database database))) + (if (and flatp + (= (length (slot-value expr 'selections)) 1)) + (mapcar #'car res) + res)))))))) diff --git a/sql/objects.lisp b/sql/objects.lisp index e4b0ca1..823df46 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -20,7 +20,7 @@ :initform nil :initarg :view-database :db-kind :virtual)) - (:metaclass standard-db-class) + (:metaclass view-metaclass) (:documentation "Superclass for all CLSQL View Classes.")) (defmethod view-database ((self standard-db-object)) @@ -29,7 +29,7 @@ (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 view-metaclass) instance slot) (declare (optimize (speed 3))) (unless *db-deserializing* (let ((slot-name (%slot-name slot)) @@ -43,7 +43,7 @@ (setf (slot-value instance slot-name) nil)))))) (call-next-method)) -(defmethod (setf slot-value-using-class) (new-value (class standard-db-class) +(defmethod (setf slot-value-using-class) (new-value (class view-metaclass) instance slot) (declare (ignore new-value instance slot)) (call-next-method)) @@ -92,7 +92,7 @@ ;; Build the database tables required to store the given view class ;; -(defmethod database-pkey-constraint ((class standard-db-class) database) +(defmethod database-pkey-constraint ((class view-metaclass) database) (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) (when keylist (format nil "CONSTRAINT ~APK PRIMARY KEY~A" @@ -144,7 +144,7 @@ the view. The argument DATABASE has a default value of (error "Class ~s not found." view-class-name))) (values)) -(defmethod %install-class ((self standard-db-class) database &aux schemadef) +(defmethod %install-class ((self view-metaclass) database &aux schemadef) (dolist (slotdef (ordered-class-slots self)) (let ((res (database-generate-column-definition (class-name self) slotdef database))) @@ -218,7 +218,7 @@ SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the superclass of the newly-defined View Class." `(progn (defclass ,class ,supers ,slots ,@options - (:metaclass standard-db-class)) + (:metaclass view-metaclass)) (finalize-inheritance (find-class ',class)))) (defun keyslots-for-class (class) diff --git a/sql/sql.lisp b/sql/sql.lisp index 6d1e375..077e27d 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -27,6 +27,10 @@ (execute-command (sql-output expr database) :database database) (values)) +(defmethod explain ((expr %sql-expression) &key (database *default-database*)) + (let ((expression (sql-output expr database))) + (format *standard-output* "explain: ~S~%" expression) + (execute-command (concatenate 'string "explain " expression)))) (defmethod query ((expr %sql-expression) &key (database *default-database*) @@ -34,6 +38,18 @@ (query (sql-output expr database) :database database :flatp flatp :result-types result-types)) +(defun truncate-database (database) + (unless (typep database 'database) + (clsql-base-sys::signal-no-database-error database)) + (unless (is-database-open database) + (database-reconnect database)) + (dolist (table (list-tables database)) + (drop-table table database)) + (dolist (index (list-indexes database)) + (drop-index index database)) + (dolist (seq (list-sequences database)) + (drop-sequence seq database))) + (defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) (database *default-database*)) "The PRINT-QUERY function takes a symbolic SQL query expression and @@ -91,11 +107,11 @@ table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." (vals nil) (av-pairs nil) (subquery nil)) - (if (null into) + (unless into (error 'clsql-sql-syntax-error :reason ":into keyword not supplied")) - (let ((ins (make-instance 'sql-insert :into into))) + (let ((insert (make-instance 'sql-insert :into into))) (with-slots (attributes values query) - ins + insert (cond ((and vals (not attrs) (not query) (not av-pairs)) (setf values vals)) ((and vals attrs (not subquery) (not av-pairs)) @@ -112,7 +128,7 @@ table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." (t (error 'clsql-sql-syntax-error :reason "bad or ambiguous keyword combination."))) - ins))) + insert))) (defun delete-records (&key (from nil) (where nil) @@ -124,12 +140,11 @@ from which the records are to be removed, and defaults to (let ((stmt (make-instance 'sql-delete :from from :where where))) (execute-command stmt :database database))) -(defun update-records (table &key - (attributes nil) - (values nil) - (av-pairs nil) - (where nil) - (database *default-database*)) +(defun update-records (table &key (attributes nil) + (values nil) + (av-pairs nil) + (where nil) + (database *default-database*)) "Changes the values of existing fields in TABLE with columns specified by ATTRIBUTES and VALUES (or AV-PAIRS) where the WHERE condition is true." @@ -216,6 +231,7 @@ condition is true." "No type conversion to SQL for ~A is defined for DB ~A." :format-arguments (list (type-of thing) (type-of database))))) + (defmethod output-sql-hash-key ((arg vector) &optional database) (list 'vector (map 'list (lambda (arg) (or (output-sql-hash-key arg database) @@ -224,7 +240,7 @@ condition is true." (defmethod output-sql (expr &optional (database *default-database*)) (write-string (database-output-sql expr database) *sql-stream*) - t) + (values)) (defmethod output-sql ((expr list) &optional (database *default-database*)) (if (null expr) @@ -239,4 +255,11 @@ condition is true." (write-char #\) *sql-stream*))) t) - +#+nil +(defmethod add-storage-class ((self database) (class symbol) &key (sequence t)) + (let ((tablename (view-table (find-class class)))) + (unless (tablep tablename) + (create-view-from-class class) + (when sequence + (create-sequence-from-class class))))) + diff --git a/tests/new-test-init.lisp b/tests/new-test-init.lisp new file mode 100644 index 0000000..c71025a --- /dev/null +++ b/tests/new-test-init.lisp @@ -0,0 +1,330 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-init.lisp +;;;; Authors: Marcus Pearce , Kevin Rosenberg +;;;; Created: 30/03/2004 +;;;; Updated: $Id: test-init.lisp 8936 2004-04-11 02:49:49Z kevin $ +;;;; +;;;; Initialisation utilities for running regression tests on CLSQL. +;;;; +;;;; ====================================================================== + +(in-package #:clsql-tests) + +(defvar *rt-connection*) +(defvar *rt-fddl*) +(defvar *rt-fdml*) +(defvar *rt-ooddl*) +(defvar *rt-oodml*) +(defvar *rt-syntax*) + +(defvar *test-database-type* nil) +(defvar *test-database-user* nil) + +(defclass thing () + ((extraterrestrial :initform nil :initarg :extraterrestrial))) + +(def-view-class person (thing) + ((height :db-kind :base :accessor height :type float :nulls-ok t + :initarg :height) + (married :db-kind :base :accessor married :type boolean :nulls-ok t + :initarg :married) + (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday) + (hobby :db-kind :virtual :initarg :hobby :initform nil))) + +(def-view-class employee (person) + ((emplid + :db-kind :key + :db-constraints :not-null + :nulls-ok nil + :type integer + :initarg :emplid) + (groupid + :db-kind :key + :db-constraints :not-null + :nulls-ok nil + :type integer + :initarg :groupid) + (first-name + :accessor first-name + :type (string 30) + :initarg :first-name) + (last-name + :accessor last-name + :type (string 30) + :initarg :last-name) + (email + :accessor employee-email + :type (string 100) + :nulls-ok t + :initarg :email) + (companyid + :type integer) + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key companyid + :foreign-key companyid + :set nil)) + (managerid + :type integer + :nulls-ok t) + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil))) + (:base-table employee)) + +(def-view-class company () + ((companyid + :db-type :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (groupid + :db-type :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (name + :type (string 100) + :initarg :name) + (presidentid + :type integer) + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key (companyid groupid) + :foreign-key (companyid groupid) + :set t))) + (:base-table company)) + + + +(defun test-connect-to-database (database-type spec) + (setf *test-database-type* database-type) + (when (>= (length spec) 3) + (setq *test-database-user* (third spec))) + + ;; Connect to the database + (clsql:connect spec + :database-type database-type + :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 employee3 nil) +(defparameter employee4 nil) +(defparameter employee5 nil) +(defparameter employee6 nil) +(defparameter employee7 nil) +(defparameter employee8 nil) +(defparameter employee9 nil) +(defparameter employee10 nil) + +(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)) + (clsql:create-view-from-class 'employee) + (clsql:create-view-from-class 'company) + + (setf company1 (make-instance 'company + :companyid 1 + :groupid 1 + :name "Widgets Inc.") + employee1 (make-instance 'employee + :emplid 1 + :groupid 1 + :married t + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Vladamir" + :last-name "Lenin" + :email "lenin@soviet.org") + employee2 (make-instance 'employee + :emplid 2 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :birthday (clsql-base:get-time) + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org") + employee3 (make-instance 'employee + :emplid 3 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :birthday (clsql-base:get-time) + :first-name "Leon" + :last-name "Trotsky" + :email "trotsky@soviet.org") + employee4 (make-instance 'employee + :emplid 4 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :birthday (clsql-base:get-time) + :first-name "Nikita" + :last-name "Kruschev" + :email "kruschev@soviet.org") + + employee5 (make-instance 'employee + :emplid 5 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Leonid" + :last-name "Brezhnev" + :email "brezhnev@soviet.org") + + employee6 (make-instance 'employee + :emplid 6 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Yuri" + :last-name "Andropov" + :email "andropov@soviet.org") + employee7 (make-instance 'employee + :emplid 7 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :birthday (clsql-base:get-time) + :first-name "Konstantin" + :last-name "Chernenko" + :email "chernenko@soviet.org") + employee8 (make-instance 'employee + :emplid 8 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :birthday (clsql-base:get-time) + :first-name "Mikhail" + :last-name "Gorbachev" + :email "gorbachev@soviet.org") + employee9 (make-instance 'employee + :emplid 9 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Boris" + :last-name "Yeltsin" + :email "yeltsin@soviet.org") + employee10 (make-instance 'employee + :emplid 10 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Vladamir" + :last-name "Putin" + :email "putin@soviet.org")) + + ;; Lenin manages everyone + (clsql:add-to-relation employee2 'manager employee1) + (clsql:add-to-relation employee3 'manager employee1) + (clsql:add-to-relation employee4 'manager employee1) + (clsql:add-to-relation employee5 'manager employee1) + (clsql:add-to-relation employee6 'manager employee1) + (clsql:add-to-relation employee7 'manager employee1) + (clsql:add-to-relation employee8 'manager employee1) + (clsql:add-to-relation employee9 'manager employee1) + (clsql:add-to-relation employee10 'manager employee1) + ;; Everyone works for Widgets Inc. + (clsql:add-to-relation company1 'employees employee1) + (clsql:add-to-relation company1 'employees employee2) + (clsql:add-to-relation company1 'employees employee3) + (clsql:add-to-relation company1 'employees employee4) + (clsql:add-to-relation company1 'employees employee5) + (clsql:add-to-relation company1 'employees employee6) + (clsql:add-to-relation company1 'employees employee7) + (clsql:add-to-relation company1 'employees employee8) + (clsql:add-to-relation company1 'employees employee9) + (clsql:add-to-relation company1 'employees employee10) + ;; Lenin is president of Widgets Inc. + (clsql:add-to-relation company1 'president employee1) + ;; store these instances + (clsql:update-records-from-instance employee1) + (clsql:update-records-from-instance employee2) + (clsql:update-records-from-instance employee3) + (clsql:update-records-from-instance employee4) + (clsql:update-records-from-instance employee5) + (clsql:update-records-from-instance employee6) + (clsql:update-records-from-instance employee7) + (clsql:update-records-from-instance employee8) + (clsql:update-records-from-instance employee9) + (clsql:update-records-from-instance employee10) + (clsql:update-records-from-instance company1)) + +(defun run-tests () + (let ((specs (read-specs))) + (unless specs + (warn "Not running tests because test configuration file is missing") + (return-from run-tests :skipped)) + (load-necessary-systems specs) + (dolist (db-type +all-db-types+) + (let ((spec (db-type-spec db-type specs))) + (when spec + (do-tests-for-backend spec db-type)))))) + +(defun load-necessary-systems (specs) + (dolist (db-type +all-db-types+) + (when (db-type-spec db-type specs) + (db-type-ensure-system db-type)))) + +(defun do-tests-for-backend (spec db-type) + (format t + "~& +******************************************************************* +*** Running CLSQL tests with ~A backend. +******************************************************************* +" db-type) + + ;; Tests of clsql-base + (ignore-errors (destroy-database spec :database-type db-type)) + (ignore-errors (create-database spec :database-type db-type)) + (with-tests (:name "CLSQL") + (test-basic spec db-type)) + + (regression-test:rem-all-tests) + (dolist (test (append *rt-connection* *rt-fddl* *rt-fdml* + *rt-ooddl* *rt-oodml* *rt-syntax*)) + (eval test)) + + (ignore-errors (destroy-database spec :database-type db-type)) + (ignore-errors (create-database spec :database-type db-type)) + (test-connect-to-database db-type spec) + + (assert *default-database*) + (test-initialise-database) + + (assert *default-database*) + (rtest:do-tests) + (disconnect))