Add update to rofl

[clinton/lisp-on-lines.git] / src / rofl.lisp

diff --git a/src/rofl.lisp b/src/rofl.lisp
index 4982223..a085c65 100644 (file)
--- a/src/rofl.lisp
+++ b/src/rofl.lisp
@@ -1,8 +1,57 @@
 (in-package :lisp-on-lines)
 
 (in-package :lisp-on-lines)
 

+;;;; NB: These could really be in upstream
+
+;;;; * A PLIST reader for postmodern.    
+(postmodern::def-row-reader symbol-plist-row-reader (fields)
+  (let ((symbols (map 'list (lambda (desc) 
+                  (postmodern::from-sql-name (postmodern::field-name desc))) fields)))
+    (loop :while (postmodern::next-row)
+          :collect (loop :for field :across fields
+                         :for symbol :in symbols
+                         :nconc (list symbol (postmodern::next-field field))))))
+
+(s-sql::def-sql-op :between (n start end)
+  `(,@(s-sql::sql-expand n) " BETWEEN " ,@(s-sql::sql-expand start) " AND " ,@(s-sql::sql-expand end)))
+
+(s-sql::def-sql-op :case (&rest clauses)
+  `("CASE " ,@(loop for (test expr) in clauses collect (format nil "WHEN ~A THEN ~A " (s-sql::sql-expand test) (s-sql::sql-expand expr))) "END"))
+
+
+;;;; now the rofl code itself
+
+(defvar *row-reader* 'symbol-plist-row-reader)
+
+(defun %query (query)
+  (cl-postgres:exec-query *database* (sql-compile query) *row-reader*))
+
+(defun select (&rest query)
+  (%query (cons :select query)))
+
+(defun prepare (&rest query)
+  (cl-postgres:prepare-query *database* "test2" (sql-compile (cons :select query))))
+
+
+(defun select-only (num &rest query)
+  (let ((results (%query `(:limit ,(cons :select query) ,num))))
+    (if (eql 1 num)
+       (first results)
+       results)))
+
+(defun insert-into (table &rest values-plist)
+  (postmodern:execute 
+   (postmodern:sql-compile `(:insert-into ,table :set ,@values-plist))))
+
+(defun update (table &rest query)
+  (postmodern:execute 
+   (postmodern:sql-compile `(:update ,table ,@query))))
+    

 
 (defclass db-access-slot-definition ()
 
 (defclass db-access-slot-definition ()

-  ((column-name  :initform nil :initarg :db-name :accessor slot-definition-column-name
+  ((column-name  :initform nil 
+                :initarg :db-name 
+                :initarg :column
+                :accessor slot-definition-column-name

                :documentation
               "If non-NIL, contains the name of the column this slot is representing.")
    (primary-key :initform nil 
                :documentation
               "If non-NIL, contains the name of the column this slot is representing.")
    (primary-key :initform nil 


@@ -20,6 +69,16 @@ constrained will be introduced.")
     :initarg :foreign-type
     :initarg :references
     :accessor slot-definition-foreign-type)
     :initarg :foreign-type
     :initarg :references
     :accessor slot-definition-foreign-type)

+   (foreign-relation
+    :initform nil
+    :initarg :referenced-from
+    :initarg :referenced-by
+    :accessor slot-definition-foreign-relation)
+   (foreign-join-spec
+    :initform nil
+    :initarg :on
+    :initarg :using
+    :accessor slot-definition-foreign-join-spec)

    (unique :initform nil :initarg :unique :accessor slot-definition-unique)
    
 
    (unique :initform nil :initarg :unique :accessor slot-definition-unique)
    
 


@@ -34,9 +93,6 @@ that, for some reason, could not be executed. If there's a slot with
 this attribute not-NIL in a class definition, then there's something
 wrong with its SQL counterpart.")))
 
 this attribute not-NIL in a class definition, then there's something
 wrong with its SQL counterpart.")))
 

-(defmethod slot-definition-column-name :around (slotd)
-  (or (call-next-method) (slot-definition-name slotd)))
-

 
 (defclass db-access-class (standard-class)
   ((table-name :initarg :table-name :initform nil :accessor class-table-name)
 
 (defclass db-access-class (standard-class)
   ((table-name :initarg :table-name :initform nil :accessor class-table-name)


@@ -89,10 +145,19 @@ inheritance and does not create any tables for it."))
   (let ((slotd (call-next-method)))
     (setf (slot-definition-primary-key-p slotd) 
          (some #'slot-definition-primary-key-p direct-slot-definitions)
   (let ((slotd (call-next-method)))
     (setf (slot-definition-primary-key-p slotd) 
          (some #'slot-definition-primary-key-p direct-slot-definitions)

+         (slot-definition-column-name slotd)
+         (or (let ((slot (find-if #'slot-definition-column-name direct-slot-definitions)))
+               (when slot
+                 (slot-definition-column-name slot)))
+             name)

          (slot-definition-transient-p slotd) 
          (every #'slot-definition-transient-p direct-slot-definitions)
          (slot-definition-foreign-type slotd) 
          (slot-definition-foreign-type (car direct-slot-definitions))
          (slot-definition-transient-p slotd) 
          (every #'slot-definition-transient-p direct-slot-definitions)
          (slot-definition-foreign-type slotd) 
          (slot-definition-foreign-type (car direct-slot-definitions))

+         (slot-definition-foreign-relation slotd) 
+         (slot-definition-foreign-relation (car direct-slot-definitions))
+         (slot-definition-foreign-join-spec slotd) 
+         (slot-definition-foreign-join-spec (car direct-slot-definitions))

          (slot-definition-not-null-p slotd) 
          (slot-definition-not-null-p (car direct-slot-definitions))
          (slot-definition-unique slotd) (slot-definition-unique (car direct-slot-definitions))
          (slot-definition-not-null-p slotd) 
          (slot-definition-not-null-p (car direct-slot-definitions))
          (slot-definition-unique slotd) (slot-definition-unique (car direct-slot-definitions))


@@ -110,43 +175,277 @@ inheritance and does not create any tables for it."))
 (defclass standard-db-access-class (db-access-class)
   ())
 
 (defclass standard-db-access-class (db-access-class)
   ())
 

-(defun dao-id-column-name (class)
+(defun find-foreign-relations (class object slotd)
+  (when (slot-boundp object (dao-id-column-name class))
+  (select-objects (slot-definition-foreign-relation slotd)
+                 :where `(:= ,(or (slot-definition-foreign-join-spec slotd) 
+                                  (dao-id-column-name class))
+                          ,(slot-value object (dao-id-column-name class))))))
+
+(defmethod slot-boundp-using-class :around 
+    ((class standard-db-access-class) object slotd)
+  (let ((bound? (call-next-method)))
+    (when (and (not bound?) (slot-definition-foreign-relation slotd))
+         (setf (slot-value-using-class class object slotd) 
+               (find-foreign-relations class object slotd)))
+
+    (call-next-method)))
+
+(defmethod slot-value-using-class :around 
+    ((class standard-db-access-class) object slotd)
+  (if (slot-definition-foreign-relation slotd)
+      (if (slot-boundp-using-class class object slotd)
+         (call-next-method)
+         (setf (slot-value-using-class class object slotd) 
+               (find-foreign-relations class object slotd)))
+      (call-next-method)))
+
+(defun set-fkey-from-slotd (value object slotd)
+  (when (slot-boundp value (dao-id-column-name (class-of value)))
+    (setf (slot-value object (slot-definition-column-name slotd))
+         (slot-value value (dao-id-column-name (class-of value))))))
+
+(defmethod (setf slot-value-using-class) :after 
+    (value (class standard-db-access-class) object slotd)
+  (when (and value 
+            (typep value 'standard-db-access-object)
+            (slot-definition-foreign-type slotd)
+            (primary-key-boundp value))
+
+    (set-fkey-from-slotd value object slotd)))
+
+(defun find-foreign-objects (db-object)
+    (let* ((class (class-of db-object)) 
+        (foreign-objects ))
+      (mapcar (lambda (x)
+               (and (slot-value-using-class class db-object x)  
+                    (slot-value-using-class class db-object  x)))
+             (remove-if-not #'lol::slot-definition-foreign-type 
+                            (lol::class-slots class)))))
+
+
+ (defun dao-id-column-name (class)

   (slot-definition-column-name
    (or (class-id-slot-definition class)
        (error "No ID slot (primary key) for ~A" class))))
 
   (slot-definition-column-name
    (or (class-id-slot-definition class)
        (error "No ID slot (primary key) for ~A" class))))
 

-(defclass described-db-access-class (standard-db-access-class described-class)
+(defun db-access-object-p (thing)
+  (typep thing 'standard-db-access-object))
+
+(defun primary-key-boundp (object)
+  (check-type object standard-db-access-object) 
+  (slot-boundp object (dao-id-column-name (class-of object))))
+
+(defclass described-db-access-class (described-class standard-db-access-class)

   ())
 
   ())
 

-(defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '()))
+(defmethod initialize-instance :around ((class standard-db-access-class) &rest initargs &key name (direct-superclasses '()) direct-slots)

   (declare (dynamic-extent initargs))
   (declare (dynamic-extent initargs))

-  (if (loop for direct-superclass in direct-superclasses
-        thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))
-      (call-next-method)
-      (apply #'call-next-method
-            class
-            :direct-superclasses
-            (append direct-superclasses
-                    (list (find-class 'standard-db-access-object)))
-            initargs)))
-
-(defmethod reinitialize-instance :around ((class standard-db-access-class) &rest initargs &key (direct-superclasses '() direct-superclasses-p))
+  (let ((direct-slots (loop for slot in direct-slots 
+                        collect (let* ((sname (getf slot :name))
+                                       (readers (getf slot :readers))
+                                       (writers (getf slot :writers)))
+                                  (setf (getf slot :readers)
+                                        (cons (intern (format nil "~A.~A"
+                                                              name sname)) readers))
+                                  (setf (getf slot :writers)
+                                        (cons `(setf ,(intern (format nil "~A.~A"
+                                                                      name sname))) writers))
+                                  slot))))
+        
+                                             
+
+    (if (loop for direct-superclass in direct-superclasses
+          thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))
+       (call-next-method)
+       (apply #'call-next-method
+              class
+              :direct-superclasses
+              (append direct-superclasses
+                      (list (find-class 'standard-db-access-object)))
+              :direct-slots direct-slots
+              initargs))))
+
+(defmethod reinitialize-instance :around ((class standard-db-access-class) 
+                                         &rest initargs 
+                                         &key (name (class-name class)) 
+                                         (direct-superclasses '() direct-superclasses-p) direct-slots)

   (declare (dynamic-extent initargs))
   (declare (dynamic-extent initargs))

-  (if (or (not direct-superclasses-p)
-         (loop for direct-superclass in direct-superclasses
-            thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object))))
-      (call-next-method)
-      (apply #'call-next-method
-            class
-            :direct-superclasses
-            (append direct-superclasses
-                    (list (find-class 'standard-db-access-object)))
-            initargs)))
+  (let ((direct-slots (loop for slot in direct-slots 
+                        collect (let* ((sname (getf slot :name))
+                                       (readers (getf slot :readers))
+                                       (writers (getf slot :writers)))
+                                  (setf (getf slot :readers)
+                                        (cons (intern (format nil "~A.~A"
+                                                              name sname)) readers))
+                                  (setf (getf slot :writers)
+                                        (cons `(setf ,(intern (format nil "~A.~A"
+                                                                      name sname))) writers))
+                                  slot))))
+        
+                                             
+
+    (if (loop for direct-superclass in direct-superclasses
+          thereis (ignore-errors (subtypep direct-superclass 'standard-db-access-object)))
+       (call-next-method)
+       (apply #'call-next-method
+              class
+              :direct-superclasses
+              (append direct-superclasses
+                      (list (find-class 'standard-db-access-object)))
+              :direct-slots direct-slots
+              initargs))))

 
 (defclass standard-db-access-object (standard-object)
   ())
 
 
 (defclass standard-db-access-object (standard-object)
   ())
 

+(defun %select-objects (type select-fn query)
+  (mapcar (curry 'make-object-from-plist type)
+         (apply select-fn (intern (format nil "*")) 
+                (if (string-equal (first query) :from)
+                    query
+                    (append `(:from ,type) query)))))
+
+(defun select-objects (type &rest query)
+  (%select-objects type #'select query))
+
+(defun select-only-n-objects (n type &rest query)
+  (let ((fields (if (eq :fields (car query))
+                   (loop 
+                      :for cons :on (cdr query)
+                      :if (not (keywordp (car cons)))
+                      :collect (car cons) into fields
+                      :else :do  
+                        (setf query cons)
+                        (return (nreverse (print fields)))
+                      :finally                        
+                        (setf query cons)
+                        (return (nreverse (print fields))))
+                      
+                   (list (intern "*")))))
+    (let ((results 
+          (%query 
+           (print `(:limit (:select 
+                     ,@fields 
+                     ,@(if (string-equal (first query) :from)
+                           (print query)
+                           (append `(:from ,type) query)))
+                    ,n)))))
+    (if (eql 1 n)
+       (make-object-from-plist type (first results))
+       (mapcar (curry 'make-object-from-plist type) results)))))
+
+(defun make-object-from-plist (type plist)
+  (let* ((class (find-class type))
+        (object (make-instance class))
+        (slotds (class-slots class)))
+        
+    (loop 
+       :for (key val) :on plist :by #'cddr 
+       :do 
+       (dolist (slotd (remove key slotds 
+                             :key #'slot-definition-column-name
+                             :test-not #'string-equal))
+
+            (setf (slot-value-using-class class object slotd) val))
+       :finally (return (reinitialize-instance object)))))
+
+(defun make-object (type &rest plist)
+  (make-object-from-plist type plist))
+
+(defun insert-object (object)
+  (let ((class (class-of object))
+       insert-query
+       delayed)
+    (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd)))
+            (push (lambda ()  (push (slot-definition-column-name slotd) insert-query)
+                          (push  val insert-query)) 
+                  delayed)))
+    (loop :for slotd in (class-slots class) 
+         :do (cond ((slot-boundp-using-class class object slotd)
+                    (cond ((or (slot-definition-foreign-relation slotd)
+                               )
+                           )
+                          ((slot-definition-foreign-type slotd)
+                           (set-fkey-from-slotd 
+                            (slot-value-using-class class object slotd) 
+                            object slotd
+)
+                           )
+                          (t 
+                           (ins slotd)) ))
+                   ((slot-definition-primary-key-p slotd)
+                    (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class)
+                                                 (slot-definition-column-name slotd)))
+                    (ins slotd ))))
+    (map nil #'funcall delayed)
+    (apply #'insert-into (class-table-name class) (nreverse insert-query))))
+  object)
+
+
+(defun update-object (object)
+  (let ((class (class-of object))
+       update-query
+       delayed)
+    (flet ((ins (slotd &optional (val (slot-value-using-class class object slotd)))
+            (push (lambda ()  (push (slot-definition-column-name slotd) update-query)
+                          (push  val update-query)) 
+                  delayed)))
+    (loop :for slotd in (class-slots class) 
+         :do (cond ((slot-boundp-using-class class object slotd)
+                    (cond ((or (slot-definition-foreign-relation slotd)
+                               )
+                           )
+                          ((slot-definition-foreign-type slotd)
+                           (set-fkey-from-slotd 
+                            (slot-value-using-class class object slotd) 
+                            object slotd
+)
+                           )
+                          (t 
+                           (ins slotd)) ))
+                   ((slot-definition-primary-key-p slotd)
+                    (setf (slot-value-using-class class object slotd) (get-default-value (class-table-name class)
+                                                 (slot-definition-column-name slotd)))
+                    (ins slotd ))))
+    (map nil #'funcall delayed)
+    (apply #'update (class-table-name class) :set (nconc  (nreverse update-query)
+                                                    (list  :where `(:= ,(dao-id-column-name class)
+                                                                    ,(slot-value object (dao-id-column-name class))
+                                                                    ))))))
+  object)
+
+(defun select-using-object (object &key (combinator :and))
+  (let ((class (class-of object))
+       select-query)
+    (flet ((sel (slotd &optional (val (slot-value-using-class class object slotd)))
+            (push `(:ilike ,(slot-definition-column-name slotd) ,(if (stringp val)
+                                                                     (format nil "~A%" val) val)) select-query)))
+    (loop :for slotd in (class-slots class) 
+         :do (cond ((slot-boundp-using-class class object slotd)
+                    (unless (or (slot-definition-foreign-relation slotd)
+                                (slot-definition-foreign-type  slotd))
+                      (sel slotd)))))
+    (if select-query
+          (select-objects (class-table-name class) 
+            :where (print `(,combinator ,@(nreverse select-query))))
+          nil))))
+  

 
 

+(defun get-default-value-query (table column)
+  (format nil "select ~A " 
+         (second (select-only 1 ':adsrc 
+                              :from 'pg_attribute 'pg_attrdef 
+                              :where `(:and (:= adnum attnum) 
+                                       (:= attname ,(s-sql::to-sql-name column)) 
+                                       (:= adrelid attrelid) 
+                                       (:= attrelid 
+                                        (:select oid 
+                                         :from pg_class 
+                                         :where (:= relname ,(s-sql::to-sql-name table)))))))))
+
+(defun get-default-value (table column)
+  (caar (query (get-default-value-query table column))))

 
 (defun find-dao (type id 
                 &key (table (class-table-name (find-class type)))
 
 (defun find-dao (type id 
                 &key (table (class-table-name (find-class type)))


@@ -154,27 +453,31 @@ inheritance and does not create any tables for it."))
                             
   "Get the dao corresponding to the given primary key,
 or return nil if it does not exist."
                             
   "Get the dao corresponding to the given primary key,
 or return nil if it does not exist."

-  (let ((row (first (query 
-             (:select '* 
+  (let ((plist 
+             (select-only 1 '* 

               :from table 
               :from table 

-               :where (:= id (or id-column-name
+               :where (list ':= id (or id-column-name

                                 (dao-id-column-name 
                                 (dao-id-column-name 

-                                 (find-class type)))))))))
-    (make-dao-from-row type row)))
+                                 (find-class type)))))))
+    (make-object-from-plist type plist)))

 
 (defmethod shared-initialize :after ((dao standard-db-access-object) 
                                     slots &rest initargs)
 
 (defmethod shared-initialize :after ((dao standard-db-access-object) 
                                     slots &rest initargs)

-  (let ((class (class-of dao)))
+  (let ((class (class-of dao))
+       (foreign-key))

     (dolist (slotd (class-slots class))
       (with-slots (foreign-type) slotd
        (when foreign-type
     (dolist (slotd (class-slots class))
       (with-slots (foreign-type) slotd
        (when foreign-type

+         (when (consp foreign-type)
+           (setf foreign-key (cdr foreign-type)
+                 foreign-type (car foreign-type)))

          (if (slot-boundp-using-class class dao slotd)
          (if (slot-boundp-using-class class dao slotd)

-             (let ((value (slot-value-using-class class dao slotd)))           
-               (unless (typep value foreign-type)
+             (let ((value (slot-value-using-class class dao slotd)))                           (unless (typep value foreign-type)

                  (if (connected-p *database*)
                      (setf (slot-value-using-class class dao slotd)
                            (find-dao foreign-type value))
                      (let ((obj (make-instance foreign-type)))
                  (if (connected-p *database*)
                      (setf (slot-value-using-class class dao slotd)
                            (find-dao foreign-type value))
                      (let ((obj (make-instance foreign-type)))

+                       (break "here")

                        (setf (slot-value-using-class 
                               (class-of obj)
                               obj
                        (setf (slot-value-using-class 
                               (class-of obj)
                               obj


@@ -187,28 +490,6 @@ or return nil if it does not exist."
       
       (slot-value-using-class class dao (class-id-slot-definition class)))))
 
       
       (slot-value-using-class class dao (class-id-slot-definition class)))))
 

-(postmodern::def-row-reader symbol-plist-row-reader (fields)
-
-  (let ((symbols (map 'list (lambda (desc) 
-                  (postmodern::from-sql-name (postmodern::field-name desc))) fields)))
-    (loop :while (postmodern::next-row)
-          :collect (loop :for field :across fields
-                         :for symbol :in symbols
-                         :nconc (list symbol (postmodern::next-field field))))))
-
-
-(setf postmodern::*result-styles* 
-      (nconc (list '(:plists symbol-plist-row-reader nil)
-                  '(:plist symbol-plist-row-reader t))
-            postmodern::*result-styles*))
-
-(defun select (&rest query)
-    (query (sql-compile (cons :select query)) :plists))
-
-(defun select-only (num &rest query)
-  (query (sql-compile `(:limit ,(cons :select query) ,num)) 
-        :plists))
-

 (defun make-dao-from-row (type row &key slots)
   (let* ((class (find-class type))
         (dao (make-instance class))
 (defun make-dao-from-row (type row &key slots)
   (let* ((class (find-class type))
         (dao (make-instance class))