From: Russ Tyndall Date: Wed, 14 Nov 2012 21:23:45 +0000 (-0500) Subject: refactor update-records-from-* functions to utilize a single codepath X-Git-Tag: v6.4.0~13 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=47d5ae2b1454553fa6d71c08862c7dfc5df97a92 refactor update-records-from-* functions to utilize a single codepath rather than reimplementing things differently in each * major clean up of normalized classes code - not many tests for this so if its being used by you please check carefully * should be a single update code path that each of the other methods feed into * less different iteration forms, I found almost all the iteration constructs in the language being used, opted to try an standardize on loop since it was already being used and tends to produce more efficient code * objects instead of unstructured lists * smaller, hopefully easier to understand functions --- diff --git a/sql/fdml.lisp b/sql/fdml.lisp index bd8d6d3..5e248ce 100644 --- a/sql/fdml.lisp +++ b/sql/fdml.lisp @@ -12,6 +12,33 @@ (in-package #:clsql-sys) +;; some helpers to make dealing with attribute-value-pairs a bit more structured +(defclass attribute-value-pair () + ((attribute :accessor attribute :initarg :attribute :initform nil) + (db-value :accessor db-value :initarg :db-value :initform nil)) + (:documentation "Represents an attribute-sql-expression and its value, used + to pass to insert/update. Was previously a two list")) + +(defun make-attribute-value-pair (slot-def value database) + (check-slot-type slot-def value) + (make-instance + 'attribute-value-pair + :attribute (sql-expression :attribute (database-identifier slot-def database)) + :db-value (db-value-from-slot slot-def value database))) + +(defun to-attributes-and-values (av-pairs) + (etypecase (first av-pairs) + (list + (loop for (a v) in av-pairs + collect a into attributes + collect v into db-values + finally (return (values attributes db-values)))) + (attribute-value-pair + (loop for pair in av-pairs + collecting (attribute pair) into attributes + collecting (db-value pair) into db-values + finally (return (values attributes db-values)))))) + ;;; Basic operations on databases (defmethod database-query-result-set ((expr %sql-expression) database @@ -110,51 +137,59 @@ used." (database *default-database*)) "Inserts records into the table specified by INTO in DATABASE which defaults to *DEFAULT-DATABASE*. There are five ways of -specifying the values inserted into each row. In the first VALUES -contains a list of values to insert and ATTRIBUTES, AV-PAIRS and -QUERY are nil. This can be used when values are supplied for all -attributes in INTO. In the second, ATTRIBUTES is a list of column -names, VALUES is a corresponding list of values and AV-PAIRS and -QUERY are nil. In the third, ATTRIBUTES, VALUES and QUERY are nil -and AV-PAIRS is an alist of (attribute value) pairs. In the -fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a -symbolic SQL query expression in which the selected columns also -exist in INTO. In the fifth method, VALUES and AV-PAIRS are nil -and ATTRIBUTES is a list of column names and QUERY is a symbolic -SQL query expression which returns values for the specified -columns." +specifying the values inserted into each row. + +In the first VALUES contains a list of values to insert and ATTRIBUTES, +AV-PAIRS and QUERY are nil. This can be used when values are supplied for all +attributes in INTO. + +In the second, ATTRIBUTES is a list of column names, VALUES is a corresponding +list of values and AV-PAIRS and QUERY are nil. + +In the third, ATTRIBUTES, VALUES and QUERY are nil and AV-PAIRS is a list +of (attribute value) pairs, or attribute-value-pair objects. + +In the fourth, VALUES, AV-PAIRS and ATTRIBUTES are nil and QUERY is a symbolic +SQL query expression in which the selected columns also exist in INTO. + +In the fifth method, VALUES and AV-PAIRS are nil and ATTRIBUTES is a list of +column names and QUERY is a symbolic SQL query expression which returns values +for the specified columns." (let ((stmt (make-sql-insert :into into :attrs attributes :vals values :av-pairs av-pairs :subquery query))) (execute-command stmt :database database))) (defun make-sql-insert (&key (into nil) - (attrs nil) - (vals nil) - (av-pairs nil) - (subquery nil)) + (attrs nil) + (vals nil) + (av-pairs nil) + (subquery nil)) (unless into - (error 'sql-user-error :message ":into keyword not supplied")) + (error 'sql-user-error :message ":into keyword not supplied")) (let ((insert (make-instance 'sql-insert :into (database-identifier into nil)))) - (with-slots (attributes values query) - insert + (with-slots (attributes values query) insert (cond ((and vals (not attrs) (not query) (not av-pairs)) (setf values vals)) + ((and vals attrs (not subquery) (not av-pairs)) (setf attributes attrs) (setf values vals)) + ((and av-pairs (not vals) (not attrs) (not subquery)) - (setf attributes (mapcar #'car av-pairs)) - (setf values (mapcar #'cadr av-pairs))) + (multiple-value-setq (attributes values) + (to-attributes-and-values av-pairs))) + ((and subquery (not vals) (not attrs) (not av-pairs)) (setf query subquery)) + ((and subquery attrs (not vals) (not av-pairs)) (setf attributes attrs) (setf query subquery)) - (t - (error 'sql-user-error - :message "bad or ambiguous keyword combination."))) + + (t (error 'sql-user-error + :message "bad or ambiguous keyword combination."))) insert))) (defun delete-records (&key (from nil) @@ -182,8 +217,8 @@ is a list of column names, VALUES is a corresponding list of values and AV-PAIRS is nil. In the third, ATTRIBUTES and VALUES are nil and AV-PAIRS is an alist of (attribute value) pairs." (when av-pairs - (setf attributes (mapcar #'car av-pairs) - values (mapcar #'cadr av-pairs))) + (multiple-value-setq (attributes values) + (to-attributes-and-values av-pairs))) (let ((stmt (make-instance 'sql-update :table (database-identifier table database) :attributes attributes :values values diff --git a/sql/generic-postgresql.lisp b/sql/generic-postgresql.lisp index 4c726da..178b3b0 100644 --- a/sql/generic-postgresql.lisp +++ b/sql/generic-postgresql.lisp @@ -284,11 +284,8 @@ (defmethod database-add-autoincrement-sequence ((self standard-db-class) (database generic-postgresql-database)) - (let ((ordered-slots (if (normalizedp self) - (ordered-class-direct-slots self) - (ordered-class-slots self)))) + (let ((ordered-slots (slots-for-possibly-normalized-class self))) (dolist (slotdef ordered-slots) - ;; ensure that referenceed sequences actually exist before referencing them (let ((sequence-name (auto-increment-sequence-name self slotdef database))) (when (and sequence-name @@ -298,10 +295,7 @@ (defmethod database-remove-autoincrement-sequence ((table standard-db-class) (database generic-postgresql-database)) - (let ((ordered-slots - (if (normalizedp table) - (ordered-class-direct-slots table) - (ordered-class-slots table)))) + (let ((ordered-slots (slots-for-possibly-normalized-class table))) (dolist (slotdef ordered-slots) ;; ensure that referenceed sequences are dropped with the table (let ((sequence-name (auto-increment-sequence-name table slotdef database))) diff --git a/sql/generics.lisp b/sql/generics.lisp index 0d1a4da..748cbd9 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -77,7 +77,7 @@ represented by SLOTS are initialised from the values of the supplied slots with other attributes having default values. Furthermore, OBJECT becomes associated with DATABASE.")) -(defgeneric update-records-from-instance (object &key database this-class) +(defgeneric update-records-from-instance (object &key database) (:documentation "Using an instance of a View Class, OBJECT, update the table that stores its instance data. DATABASE defaults to @@ -93,7 +93,7 @@ associated with DATABASE.")) table of the database associated with OBJECT. If OBJECT is not yet associated with a database, an error is signalled.")) -(defgeneric update-instance-from-records (object &key database this-class) +(defgeneric update-instance-from-records (object &key database) (:documentation "Updates the slot values of the View Class instance OBJECT using the attribute values of the appropriate table of DATABASE @@ -122,7 +122,7 @@ effects. Methods specialised on particular View Classes can be used to specify any operations that need to be made on View Classes instances which have been updated in calls to SELECT.")) -(defgeneric update-slot-with-null (instance slotname slotdef) +(defgeneric update-slot-with-null (instance 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 diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp index 1723940..75ccb5e 100644 --- a/sql/kmr-mop.lisp +++ b/sql/kmr-mop.lisp @@ -58,6 +58,23 @@ #+mop-slot-order-reversed (reverse (class-slots class)) #-mop-slot-order-reversed (class-slots class)) +(defun ordered-class-direct-slots (class) + "Gets an ordered list of direct class slots" + ;; NB: this used to return effective-slot-definitions in direct + ;; opposition to the function name. Not sure why + (setf class (to-class class)) + #+mop-slot-order-reversed (reverse (class-direct-slots class)) + #-mop-slot-order-reversed (class-direct-slots class)) + +(defun find-class-slot-by-name (class slot-name &optional direct?) + "Looks up a direct-slot-definition by name" + (setf class (to-class class)) + (find (to-slot-name slot-name) + (if direct? + (ordered-class-direct-slots class) + (ordered-class-slots class)) + :key #'slot-definition-name)) + ;; Lispworks has symbol for slot rather than the slot instance (defun %svuc-slot-name (slot) #+lispworks slot diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index ddaee4f..d6ea70f 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -103,17 +103,6 @@ base-table)) (class-name class))))) -(defgeneric ordered-class-direct-slots (class)) -(defmethod ordered-class-direct-slots ((self standard-db-class)) - (let ((direct-slot-names - (mapcar #'slot-definition-name (class-direct-slots self))) - (ordered-direct-class-slots '())) - (dolist (slot (ordered-class-slots self)) - (let ((slot-name (slot-definition-name slot))) - (when (find slot-name direct-slot-names) - (push slot ordered-direct-class-slots)))) - (nreverse ordered-direct-class-slots))) - (defmethod initialize-instance :around ((class standard-db-class) &rest all-keys &key direct-superclasses base-table @@ -201,18 +190,14 @@ (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) - (if (normalizedp class) - (ordered-class-direct-slots class) - (ordered-class-slots class)))))) + (slots-for-possibly-normalized-class class))))) #+(or sbcl allegro) (defmethod finalize-inheritance :after ((class standard-db-class)) (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) - (if (normalizedp class) - (ordered-class-direct-slots class) - (ordered-class-slots class))))) + (slots-for-possibly-normalized-class class)))) ;; return the deepest view-class ancestor for a given view class @@ -586,3 +571,31 @@ implementations." (and (setf cls (ignore-errors (find-class name))) (typep cls 'standard-db-class) cls)) + +(defun slots-for-possibly-normalized-class (class) + (if (normalizedp class) + (ordered-class-direct-slots class) + (ordered-class-slots class))) + +(defun direct-normalized-slot-p (class slot-name) + "Is this a normalized class and if so is the slot one of our direct slots?" + (setf slot-name (to-slot-name slot-name)) + (and (normalizedp class) + (member slot-name (ordered-class-direct-slots class) + :key #'slot-definition-name))) + +(defun not-direct-normalized-slot-p (class slot-name) + "Is this a normalized class and if so is the slot not one of our direct slots?" + (setf slot-name (to-slot-name slot-name)) + (and (normalizedp class) + (not (member slot-name (ordered-class-direct-slots class) + :key #'slot-definition-name)))) + +(defun slot-has-default-p (slot) + "returns nil if the slot does not have a default constraint" + (let* ((constraints + (when (typep slot '(or view-class-direct-slot-definition + view-class-effective-slot-definition)) + (listify (view-class-slot-db-constraints slot))))) + (member :default constraints))) + diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 2d1d73b..9fb218f 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -106,9 +106,7 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (defmethod %install-class ((self standard-db-class) database &key (transactions t)) (let ((schemadef '()) - (ordered-slots (if (normalizedp self) - (ordered-class-direct-slots self) - (ordered-class-slots self)))) + (ordered-slots (slots-for-possibly-normalized-class self))) (dolist (slotdef ordered-slots) (let ((res (database-generate-column-definition self slotdef database))) (when res diff --git a/sql/oodml.lisp b/sql/oodml.lisp index d61c58a..5469a03 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -105,30 +105,31 @@ -;; Called by 'get-slot-values-from-view' -;; +(defmethod update-slot-with-null ((object standard-db-object) slotdef) + (setf (easy-slot-value object slotdef) + (slot-value slotdef 'void-value))) -(defmethod update-slot-from-db ((instance standard-db-object) slotdef value) +(defmethod update-slot-from-db-value ((instance standard-db-object) slotdef value) + "This gets a value from the database and turns it itno a lisp value + based on the slot's slot-db-reader or baring that read-sql-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 (specified-type slotdef))) - (cond ((and value (null slot-reader)) - (setf (slot-value instance slot-name) - (read-sql-value value (delistify slot-type) - (choose-database-for-instance instance) - (database-underlying-type - (choose-database-for-instance 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 '(or symbol function)) - (setf (slot-value instance slot-name) - (apply slot-reader (list value)))) - (t - (error "Slot reader is of an unusual type."))))) + (cond + ((null value) (update-slot-with-null instance slotdef)) + ((null slot-reader) + (setf (easy-slot-value instance slotdef) + (read-sql-value value (delistify slot-type) + (choose-database-for-instance instance) + (database-underlying-type + (choose-database-for-instance instance))))) + (t (etypecase slot-reader + ((or symbol function) + (setf (easy-slot-value instance slotdef) + (apply slot-reader (list value)))) + (string + (setf (easy-slot-value instance slotdef) + (format nil slot-reader value)))))))) (defmethod key-value-from-db (slotdef value database) (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) @@ -169,167 +170,206 @@ (format nil "Invalid value ~A in slot ~A, not of type ~A." val (slot-definition-name slotdef) slot-type)))))) -;; -;; 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)) - -(defmethod update-record-from-slot ((obj standard-db-object) slot &key - (database *default-database*)) - (let* ((database (choose-database-for-instance obj database)) - (view-class (class-of obj))) - (when (normalizedp view-class) - ;; If it's normalized, find the class that actually contains - ;; the slot that's tied to the db - (setf view-class - (do ((this-class view-class - (car (class-direct-superclasses this-class)))) - ((member slot - (mapcar #'(lambda (esd) (slot-definition-name esd)) - (ordered-class-direct-slots this-class))) - this-class)))) - (let* ((vct (view-table view-class)) - (sd (slotdef-for-slot-with-class slot view-class))) - (check-slot-type sd (slot-value obj slot)) - (let* ((att (database-identifier sd database)) - (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 :this-class view-class) - :database database)) - ((and vct sd (not (view-database obj))) - (insert-records :into (sql-expression :table vct) - :attributes (list (sql-expression :attribute att)) - :values (list val) - :database database) - (setf (slot-value obj 'view-database) database)) - (t - (error "Unable to update record."))))) - (values))) - -(defmethod update-record-from-slots ((obj standard-db-object) slots &key - (database *default-database*)) - (when (normalizedp (class-of obj)) - ;; FIXME: Rewrite to bundle slots for same table to be written - ;; as avpairs (like how is done for non-normalized view-classes below) - (dolist (slot slots) - (update-record-from-slot obj slot :database database)) - (return-from update-record-from-slots (values))) - - (let* ((database (choose-database-for-instance obj database)) - (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 (database-identifier s database)) - (db-value-from-slot s val database)))) - sds))) - (cond ((and avps (view-database obj)) + "Used to copy values from the database into the object + used by things like find-all and select" + (loop for slot in slotdeflist + for value in values + do (update-slot-from-db-value obj slot value)) + obj) + +(defclass class-and-slots () + ((view-class :accessor view-class :initarg :view-class :initform nil) + (slot-defs :accessor slot-defs :initarg :slot-defs :initform nil)) + (:documentation "A helper class to keep track of which slot-defs from a + table need to be updated, a normalized class might have many of these + because each of its parent classes might represent some other table and we + need to match which slots came from which parent class/table")) + +(defun make-class-and-slots (c &optional s) + "Create a new class-and-slots object" + (make-instance 'class-and-slots :view-class c :slot-defs (listify s) )) + +(defmethod view-table ((o class-and-slots)) + "get the view-table of the view-class of o" + (view-table (view-class o))) + +(defmethod attribute-value-pairs ((def class-and-slots) (o standard-db-object) + database) + "for a given class-and-slots and object, create the sql-expression & value pairs + that need to be sent to the database" + (loop for s in (slot-defs def) + for n = (to-slot-name s) + when (slot-boundp o n) + collect (make-attribute-value-pair s (slot-value o n) database))) + +(defmethod view-classes-and-slots-by-name ((obj standard-db-object) slots-to-match) + "If it's normalized, find the class that actually contains + the slot that's tied to the db, + + otherwise just search the current class + " + (let* ((view-class (class-of obj)) + (normalizedp (normalizedp view-class)) + rtns) + (labels ((get-c&s-obj (class) + (or (find class rtns :key #'view-class) + (first (push (make-class-and-slots class) rtns)))) + (associate-slot-with-class (class slot) + "Find the best class to associate with the slot. If it is + normalized then it needs to be a direct slot otherwise it just + needs to be on the class." + (let ((sd (find-class-slot-by-name class slot normalizedp))) + (if sd + ;;we found it directly or it's (not normalized) + (pushnew sd (slot-defs (get-c&s-obj class))) + (when normalizedp + (loop for parent in (class-direct-superclasses class) + until (associate-slot-with-class parent slot)))) + sd))) + (loop + for in-slot in (listify slots-to-match) + do (associate-slot-with-class view-class in-slot))) + rtns)) + +(defun update-auto-increments-keys (class obj database) + ;; handle pulling any autoincrement values into the object + (let ((pk-slots (keyslots-for-class class)) + (table (view-table class)) + new-pk-value) + (labels ((do-update (slot) + (when (and (null (easy-slot-value obj slot)) + (auto-increment-column-p slot database)) + (update-slot-from-db-value + obj slot + (or new-pk-value + (setf new-pk-value + (database-last-auto-increment-id + database table slot)))))) + (chain-primary-keys (in-class) + "This seems kindof wrong, but this is mostly how it was working, so + its here to keep the normalized code path working" + (when (typep in-class 'standard-db-class) + (loop for slot in (keyslots-for-class in-class) + do (do-update slot)) + (loop for c in (class-direct-superclasses in-class) + do (chain-primary-keys c))))) + (loop for slot in pk-slots do (do-update slot)) + (let ((direct-class (to-class obj))) + (when (and new-pk-value (normalizedp direct-class)) + (chain-primary-keys direct-class))) + new-pk-value))) + +(defmethod %update-instance-helper + (class-and-slots obj database + &aux (avps (attribute-value-pairs class-and-slots obj database))) + ;; we dont actually need to update anything on this particular parent class + (unless avps (return-from %update-instance-helper)) + + (let* ((view-class (view-class class-and-slots)) + (table (view-table view-class)) + (table-sql (sql-expression :table table))) + + ;; view database is the flag we use to tell it was pulled from a database + ;; and thus probably needs an update instead of an insert + (cond ((view-database obj) (let ((where (key-qualifier-for-instance - obj :database database))) + obj :database database :this-class view-class))) (unless where - (error "update-record-from-slots: could not generate a where clause for ~a" obj)) - (update-records (sql-expression :table vct) + (error "update-record-from-*: could not generate a where clause for ~a using ~A" + obj view-class)) + (update-records table-sql :av-pairs avps :where where :database database))) - ((and avps (not (view-database obj))) - (insert-records :into (sql-expression :table vct) + (T ;; was not pulled from the db so insert it + ;; avps MUST contain any primary key slots set + ;; by previous inserts of the same object into different + ;; tables (ie: normalized stuff) + (insert-records :into table-sql :av-pairs avps :database database) - (setf (slot-value obj 'view-database) database)) - (t - (error "Unable to update records")))) + (update-auto-increments-keys view-class obj database) + ;; we dont set view database here, because there could be + ;; N of these for each call to update-record-from-* because + ;; of normalized classes + )) + (update-slot-default-values obj class-and-slots))) + +(defmethod update-record-from-slots ((obj standard-db-object) slots + &key (database *default-database*)) + (setf slots (listify slots)) + (let* ((classes-and-slots (view-classes-and-slots-by-name obj slots)) + (database (choose-database-for-instance obj database))) + (loop for class-and-slots in classes-and-slots + do (%update-instance-helper class-and-slots obj database)) + (setf (slot-value obj 'view-database) database)) (values)) +(defmethod update-record-from-slot + ((obj standard-db-object) slot &key (database *default-database*)) + (update-record-from-slots obj slot :database database)) + +(defun %slot-storedp (slot-def) + "Whether or not a slot should be stored in the database based on its db-kind + and whether it is bound" + (member (view-class-slot-db-kind slot-def) '(:base :key))) + +(defmethod view-classes-and-storable-slots-for-instance ((obj standard-db-object)) + "Get a list of all the tables we need to update and the slots on them + + for non normalized classes we return the class and all its storable slots + + for normalized classes we return a list of direct slots and the class they + came from for each normalized view class + " + (let* ((view-class (class-of obj)) + rtns) + (labels ((storable-slots (class) + (loop for sd in (slots-for-possibly-normalized-class class) + when (%slot-storedp sd) + collect sd)) + (get-classes-and-slots (class &aux (normalizedp (normalizedp class))) + (let ((slots (storable-slots class))) + (when slots + (push (make-class-and-slots class slots) rtns))) + (when normalizedp + (loop for new-class in (class-direct-superclasses class) + do (when (typep new-class 'standard-db-class) + (get-classes-and-slots new-class)))))) + (get-classes-and-slots view-class)) + rtns)) + +(defmethod primary-key-slot-values ((obj standard-db-object) + &key class slots ) + (defaulting class (class-of obj) + slots (keyslots-for-class class)) + (loop for slot in slots + collect (easy-slot-value obj slot))) + +(defmethod update-slot-default-values ((obj standard-db-object) + classes-and-slots) + "Makes sure that if a class has unfilled slots that claim to have a default, + that we retrieve those defaults from the database + + TODO: use update slots-from-record instead to batch this!" + (loop for class-and-slots in (listify classes-and-slots) + do (loop for slot in (slot-defs class-and-slots) + do (when (and (slot-has-default-p slot) + (not (easy-slot-value obj slot))) + (update-slot-from-record obj (to-slot-name slot)))))) + (defmethod update-records-from-instance ((obj standard-db-object) - &key database this-class) + &key (database *default-database*)) + "Updates the records in the database associated with this object if + view-database slot on the object is nil then the object is assumed to be + new and is inserted" (let ((database (choose-database-for-instance obj database)) - (pk nil)) - (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 (database-identifier slot database)) - (db-value-from-slot slot value database))))) - (let* ((view-class (or this-class (class-of obj))) - (pk-slot (car (keyslots-for-class view-class))) - (pk-name (when pk-slot (slot-definition-name pk-slot))) - (view-class-table (view-table view-class)) - (pclass (car (class-direct-superclasses view-class)))) - (when (normalizedp view-class) - (setf pk (update-records-from-instance obj :database database - :this-class pclass)) - (when pk-slot - (setf (slot-value obj pk-name) pk))) - (let* ((slots (remove-if-not #'slot-storedp - (if (normalizedp view-class) - (ordered-class-direct-slots view-class) - (ordered-class-slots view-class)))) - (record-values (mapcar #'slot-value-list slots))) - - (cond ((and (not (normalizedp view-class)) - (not record-values)) - (error "No settable slots.")) - ((and (normalizedp view-class) - (not record-values)) - nil) - ((view-database obj) - ;; if this slot is set, the database object was returned from a select - ;; and has already been in the database, so we must need an update - (update-records (sql-expression :table view-class-table) - :av-pairs record-values - :where (key-qualifier-for-instance - obj :database database - :this-class view-class) - :database database) - (when pk-slot - (setf pk (or pk - (slot-value obj pk-name))))) - (t - (insert-records :into (sql-expression :table view-class-table) - :av-pairs record-values - :database database) - (when (and pk-slot (not pk)) - (setf pk - (when (auto-increment-column-p pk-slot database) - (setf (slot-value obj pk-name) - (database-last-auto-increment-id - database view-class-table pk-slot))))) - (when pk-slot - (setf pk (or pk - (and (slot-boundp obj pk-name) - (slot-value obj pk-name))))) - (when (eql this-class nil) - (setf (slot-value obj 'view-database) database))))))) - ;; handle slots with defaults - (let* ((view-class (or this-class (class-of obj))) - (slots (if (normalizedp view-class) - (ordered-class-direct-slots view-class) - (ordered-class-slots view-class)))) - (dolist (slot slots) - (let ((slot-name (slot-definition-name slot))) - (when (and (slot-exists-p slot 'db-constraints) - (listp (view-class-slot-db-constraints slot)) - (member :default (view-class-slot-db-constraints slot))) - (unless (and (slot-boundp obj slot-name) - (slot-value obj slot-name)) - (update-slot-from-record obj slot-name)))))) - - pk)) + (classes-and-slots (view-classes-and-storable-slots-for-instance obj))) + (loop for class-and-slots in classes-and-slots + do (%update-instance-helper class-and-slots obj database)) + (setf (slot-value obj 'view-database) database) + (primary-key-slot-values obj))) (defmethod delete-instance-records ((instance standard-db-object) &key database) (let ((database (choose-database-for-instance instance database)) @@ -379,9 +419,7 @@ (setf view-class (do ((this-class view-class (car (class-direct-superclasses this-class)))) - ((member slot - (mapcar #'(lambda (esd) (slot-definition-name esd)) - (ordered-class-direct-slots this-class))) + ((direct-normalized-slot-p this-class slot) this-class)))) (let* ((view-table (sql-expression :table (view-table view-class))) (vd (choose-database-for-instance instance database)) @@ -394,10 +432,6 @@ (setf (slot-value instance 'view-database) vd) (get-slot-values-from-view instance (list slot-def) (car res)))))) -(defmethod update-slot-with-null ((object standard-db-object) - slotname - slotdef) - (setf (slot-value object slotname) (slot-value slotdef 'void-value))) (defvar +no-slot-value+ '+no-slot-value+) @@ -1030,10 +1064,7 @@ maximum of MAX-LEN instances updated in each query." (mapc #'(lambda (jo) ;; find all immediate-select slots and join-vals for this object (let* ((jo-class (class-of jo)) - (slots - (if (normalizedp jo-class) - (class-direct-slots jo-class) - (class-slots jo-class))) + (slots (slots-for-possibly-normalized-class jo-class)) (pos-list (remove-if #'null (mapcar #'(lambda (s) diff --git a/sql/utils.lisp b/sql/utils.lisp index e498f16..12d5d28 100644 --- a/sql/utils.lisp +++ b/sql/utils.lisp @@ -16,6 +16,11 @@ (in-package #:clsql-sys) +(defmacro defaulting (&rest place-value-plist) + `(progn + ,@(loop for (place value . rest) on place-value-plist by #'cddr + collect `(unless ,place (setf ,place ,value))))) + (defun %get-int (v) (etypecase v (string (parse-integer v :junk-allowed t)) @@ -437,3 +442,27 @@ removed. keys are searched with #'MEMBER" #+sbcl :weakness #+sbcl :value ,@args) )) + +(defun to-slot-name (slot) + "try to turn what we got representing the slot into a slot name" + (etypecase slot + (symbol slot) + (slot-definition (slot-definition-name slot)))) + +(defun to-class (it) + (etypecase it + (class it) + (symbol (find-class it)) + (standard-object (class-of it)))) + +(defun easy-slot-value (obj slot) + "like slot-value except it accepts slot-names or defs + and returns nil when the slot is unbound" + (let ((n (to-slot-name slot))) + (when (and obj (slot-boundp obj n)) + (slot-value obj n)))) + +(defun (setf easy-slot-value) (new obj slot) + "like slot-value except it accepts slot-names or defs" + (setf (slot-value obj (to-slot-name slot)) new)) +