Changes from maxclaims branch (git).
[clinton/lisp-on-lines.git] / src / rofl.lisp
index 48cc0cc..d26843f 100644 (file)
@@ -1,8 +1,49 @@
 (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) 'symbol-plist-row-reader))
+
+(defun select (&rest query)
+  (%query (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))))
+    
 
 (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 
@@ -34,9 +75,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.")))
 
-(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)
@@ -89,6 +127,11 @@ 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)
+         (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) 
@@ -110,6 +153,22 @@ inheritance and does not create any tables for it."))
 (defclass standard-db-access-class (db-access-class)
   ())
 
+(defmethod ensure-class-using-class :around ((class standard-db-access-class) name &rest args &key direct-slots &allow-other-keys)
+       (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))))
+        
+                                             
+       (apply #'call-next-method class name :direct-slots direct-slots args)))
+
 (defun dao-id-column-name (class)
   (slot-definition-column-name
    (or (class-id-slot-definition class)
@@ -146,6 +205,60 @@ inheritance and does not create any tables for it."))
 (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 find-dao (type id 
@@ -154,20 +267,24 @@ 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."
-  (let ((row (first (query 
-             (:select '* 
+  (let ((plist 
+             (select-only 1 '* 
               :from table 
-               :where (:= id (or id-column-name
+               :where (list ':= id (or 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)
-  (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
+         (when (consp foreign-type)
+           (setf foreign-key (cdr foreign-type)
+                 foreign-type (car foreign-type)))
          (if (slot-boundp-using-class class dao slotd)
              (let ((value (slot-value-using-class class dao slotd)))           
                (unless (typep value foreign-type)