From: Russ Tyndall <russ@acceleration.net>
Date: Sun, 19 Jun 2011 17:25:58 +0000 (-0400)
Subject: BUG FIX update-records-from-instance threw errors if pkey-slot was unbound
X-Git-Tag: v6.0.0~4^2~16
X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=ec4ecda1dc9e256b921a3ce7ac420441f848974b

BUG FIX update-records-from-instance threw errors if pkey-slot was unbound
---

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index ecfc9fa..ffcf02a 100644
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -267,13 +267,14 @@
                        (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 (slot-definition-name pk-slot)) pk)))
+            (setf (slot-value obj pk-name) pk)))
         (let* ((slots (remove-if-not #'slot-storedp
                                      (if (normalizedp view-class)
                                          (ordered-class-direct-slots view-class)
@@ -297,36 +298,36 @@
                                  :database database)
                  (when pk-slot
                    (setf pk (or pk
-                                (slot-value obj (slot-definition-name pk-slot))))))
+                                (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 (slot-definition-name pk-slot))
+                            (setf (slot-value obj pk-name)
                                   (database-last-auto-increment-id
                                    database view-class-table pk-slot)))))
 		  (when pk-slot
 		    (setf pk (or pk
-				 (slot-value
-				  obj (slot-definition-name pk-slot)))))
-		  (when (eql this-class nil)
+                                 (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)))) 
+		     (ordered-class-slots view-class))))
       (dolist (slot slots)
-	(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-definition-name slot))
-		       (slot-value obj (slot-definition-name slot)))
-	    (update-slot-from-record obj (slot-definition-name slot))))))
+        (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))