X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=usql%2Fobjects.lisp;fp=usql%2Fobjects.lisp;h=757848c95fab9465ef7aff332e0db40dd944b61c;hb=ce0e343835a040406678dff74a62d1b0cb56f317;hp=0000000000000000000000000000000000000000;hpb=edd1963395a5b5e5f91ef975fcd329975ae367e2;p=clsql.git diff --git a/usql/objects.lisp b/usql/objects.lisp new file mode 100644 index 0000000..757848c --- /dev/null +++ b/usql/objects.lisp @@ -0,0 +1,1108 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: objects.lisp +;;;; Updated: <04/04/2004 12:07:55 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; The CLSQL-USQL Object Oriented Data Definitional Language (OODDL) +;;;; and Object Oriented Data Manipulation Language (OODML). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + +(defclass standard-db-object () + ((view-database + :initform nil + :initarg :view-database + :db-kind :virtual)) + (:metaclass standard-db-class) + (:documentation "Superclass for all CLSQL-USQL 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) + (declare (optimize (speed 3))) + (unless *db-deserializing* + (let ((slot-name (%slot-name slot)) + (slot-object (%slot-object slot class))) + (when (and (eql (view-class-slot-db-kind slot-object) :join) + (not (slot-boundp instance slot-name))) + (let ((*db-deserializing* t)) + (if (view-database instance) + (setf (slot-value instance slot-name) + (fault-join-slot class instance slot-object)) + (setf (slot-value instance slot-name) nil)))))) + (call-next-method)) + +(defmethod (setf slot-value-using-class) (new-value (class standard-db-class) + instance slot) + (call-next-method)) + +;; JMM - Can't go around trying to slot-access a symbol! Guess in +;; CMUCL slot-name is the actual slot _object_, while in lispworks it +;; is a lowly symbol (the variable is called slot-name after all) so +;; the object (or in MOP terminology- the "slot definition") has to be +;; retrieved using find-slot-definition + +(defun %slot-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) + +(defmethod initialize-instance :around ((class standard-db-object) + &rest all-keys + &key &allow-other-keys) + (declare (ignore all-keys)) + (let ((*db-deserializing* t)) + (call-next-method))) + +(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 standard-db-class) 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))))) + + +#.(locally-enable-sql-reader-syntax) + +(defun ensure-schema-version-table (database) + (unless (table-exists-p "usql_object_v" :database database) + (create-table [usql_object_v] '(([name] (string 32)) + ([vers] integer) + ([def] (string 32))) + :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 [usql_object_v] + :where [= [name] (sql-escape (class-name tclass))] + :database database) + (insert-records :into [usql_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) + (ensure-schema-version-table database) + (update-schema-version-records view-class-name :database database)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defmethod %install-class ((self standard-db-class) database &aux schemadef) + (dolist (slotdef (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) + (delete-records :from [usql_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." + `(defclass ,class ,supers ,slots ,@options + (:metaclass standard-db-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 (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) + (let ((slot-type (slot-definition-type slotdef))) + (if (listp slot-type) + (cons (find-symbol (symbol-name (car slot-type)) :usql-sys) + (cdr slot-type)) + (find-symbol (symbol-name slot-type) :usql-sys)))) + +(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))) + (cond ((and value (null slot-reader)) + (setf (slot-value instance slot-name) + (read-sql-value value (delistify slot-type) + (view-database instance)))) + ((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*)) + (let* ((vct (view-table (class-of obj))) + (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 (view-database obj)) + (update-records (sql-expression :table vct) + :attributes (list (sql-expression + :attribute att)) + :values (list val) + :where (key-qualifier-for-instance + obj :database database) + :database (view-database obj))) + ((and vct sd (not (view-database obj))) + (install-instance obj :database database)) + (t + (error "Unable to update record."))))) + (values)) + +(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))) + (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 (view-database obj)) + (update-records (sql-expression :table vct) + :av-pairs avps + :where (key-qualifier-for-instance + obj :database database) + :database (view-database obj))) + ((and avps (not (view-database obj))) + (insert-records :into (sql-expression :table vct) + :av-pairs avps + :database database) + (setf (slot-value obj 'view-database) database)) + (t + (error "Unable to update records")))) + (values)) + +(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 (view-database obj) + (update-records (sql-expression :table view-class-table) + :av-pairs record-values + :where (key-qualifier-for-instance + obj :database database) + :database (view-database obj)) + (progn + (insert-records :into (sql-expression :table view-class-table) + :av-pairs record-values + :database database) + (setf (slot-value obj 'view-database) database))) + (values)))) + +(defmethod install-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.")) + (unless + (let ((obj-db (slot-value obj 'view-database))) + (when obj-db + (equal obj-db database)))) + (insert-records :into (sql-expression :table view-class-table) + :av-pairs record-values + :database 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)) + (let ((val (slot-value instance (slot-definition-name slot)))) + (typecase val + (list + (if (gethash :target-slot (view-class-slot-db-info slot)) + ;; For relations with target-slot, we delete just the join instance + (mapcar #'(lambda (obj) + (delete-instance-records obj)) + (fault-join-slot-raw (class-of instance) instance slot)) + (dolist (obj val) + (delete-instance-records obj)))) + (standard-db-object + (delete-instance-records val))))) + +(defmethod nullify-join-foreign-keys ((instance standard-db-object) slot) + (let* ((dbi (view-class-slot-db-info slot)) + (fkeys (gethash :foreign-keys dbi))) + (mapcar #'(lambda (fk) + (if (view-class-slot-nulls-ok slot) + (setf (slot-value instance fk) nil) + (warn "Nullify delete rule cannot set slot not allowing nulls to nil"))) + (if (listp fkeys) fkeys (list fkeys))))) + +(defmethod handle-nullify-delete-rule ((instance standard-db-object) + (slot + view-class-effective-slot-definition)) + (let ((dbi (view-class-slot-db-info slot))) + (if (gethash :set dbi) + (if (gethash :target-slot (view-class-slot-db-info slot)) + ;;For relations with target-slot, we delete just the join instance + (mapcar #'(lambda (obj) + (nullify-join-foreign-keys obj slot)) + (fault-join-slot-raw (class-of instance) instance slot)) + (dolist (obj (slot-value instance (slot-definition-name slot))) + (nullify-join-foreign-keys obj slot))) + (nullify-join-foreign-keys + (slot-value instance (slot-definition-name slot)) slot)))) + +(defmethod propogate-deletes ((instance standard-db-object)) + (let* ((view-class (class-of instance)) + (joins (remove-if #'(lambda (sd) + (not (equal (view-class-slot-db-kind sd) :join))) + (class-slots view-class)))) + (dolist (slot joins) + (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot)))) + (cond + ((eql delete-rule :cascade) + (handle-cascade-delete-rule instance slot)) + ((eql delete-rule :deny) + (when (slot-value instance (slot-definition-name slot)) + (error + "Unable to delete slot ~A, because it has a deny delete rule." + slot))) + ((eql delete-rule :nullify) + (handle-nullify-delete-rule instance slot)) + (t t)))))) + +(defgeneric delete-instance-records (instance) + (:documentation + "Deletes the records represented by INSTANCE from the database +associated with it. If instance has no associated database, an error +is signalled.")) + +(defmethod delete-instance-records ((instance standard-db-object)) + (let ((vt (sql-expression :table (view-table (class-of instance)))) + (vd (or (view-database instance) *default-database*))) + (when vd + (let ((qualifier (key-qualifier-for-instance instance :database vd))) + (with-transaction (:database vd) + (propogate-deletes instance) + (delete-records :from vt :where qualifier :database vd) + (setf (slot-value instance 'view-database) nil))))) + (values)) + +(defgeneric update-instance-from-records (instance &key database) + (: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-records ((instance standard-db-object) + &key (database *default-database*)) + (let* ((view-class (find-class (class-name (class-of instance)))) + (view-table (sql-expression :table (view-table view-class))) + (vd (or (view-database instance) database)) + (view-qual (key-qualifier-for-instance instance :database vd)) + (sels (generate-selection-list view-class)) + (res (apply #'select (append (mapcar #'cdr sels) + (list :from view-table + :where view-qual))))) + (get-slot-values-from-view instance (mapcar #'car sels) (car res)))) + +(defgeneric update-slot-from-record (instance slot &key database) + (:documentation + "Updates the value in the slot SLOT 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-slot-from-record ((instance standard-db-object) + slot &key (database *default-database*)) + (let* ((view-class (find-class (class-name (class-of instance)))) + (view-table (sql-expression :table (view-table view-class))) + (vd (or (view-database instance) database)) + (view-qual (key-qualifier-for-instance instance :database vd)) + (slot-def (slotdef-for-slot-with-class slot view-class)) + (att-ref (generate-attribute-reference view-class slot-def)) + (res (select att-ref :from view-table :where view-qual))) + (get-slot-values-from-view instance (list slot-def) (car 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) "") + ((subtypep type 'integer) 0) + ((subtypep type 'float) (float 0.0)) + ((subtypep type 'list) nil) + ((subtypep type 'boolean) nil) + ((subtypep type 'symbol) nil) + ((subtypep type 'keyword) nil) + ((subtypep type 'wall-time) 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 ((instance 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) + (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) + (declare (ignore 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)) + "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 'boolean)) 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) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) + (declare (ignore database)) + (if (keywordp val) + (symbol-name val) + (if val + (concatenate 'string + (package-name (symbol-package 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 'boolean)) 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)) + (if (find #\: val) + (read-from-string val) + (intern (string-upcase val) "KEYWORD")))) + +(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 'boolean)) 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))) + + +;; ------------------------------------------------------------ +;; Logic for 'faulting in' :join slots + +(defun fault-join-slot-raw (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))) + (when jq + (select jc :where jq))))) + +(defun fault-join-slot (class instance slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (res (fault-join-slot-raw class instance 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 instance 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 instance slt) + (not (null (slot-value instance 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 instance 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)))))) + + +(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 from group-by having offset limit) + (optimize (debug 3) (speed 1))) + (let* ((*db-deserializing* t) + (*default-database* (or database (error 'clsql-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)))))) + ;;(format t "~%fullsels is : ~A" fullsels) + (setq res (apply #'select (append (mapcar #'cdr fullsels) + (cons :from (list tables)) args))) + (flet ((build-instance (vals) + (flet ((%build-instance (vclass selects) + (let ((class-name (class-name vclass)) + (db-vals (butlast vals + (- (list-length vals) + (list-length selects)))) + cache-key) + (setf vals (nthcdr (list-length selects) vals)) + (loop for select in selects + for value in db-vals + do + (when (eql (slot-value (car select) 'db-kind) + :key) + (push + (key-value-from-db (car select) value + *default-database*) + cache-key))) + (push class-name cache-key) + (%make-fresh-object class-name + (mapcar #'car selects) + db-vals)))) + (let ((instances (mapcar #'%build-instance sclasses sels))) + (if (= (length sclasses) 1) + (car instances) + instances))))) + (remove-if #'null (mapcar #'build-instance res))))))) + +(defun %make-fresh-object (class-name slots values) + (let* ((*db-initializing* t) + (obj (make-instance class-name + :view-database *default-database*))) + (setf obj (get-slot-values-from-view obj slots values)) + (postinitialize obj) + obj)) + +(defmethod postinitialize ((self t)) + ) + +(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) + (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))))))))