(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 ()
- ((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
: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)
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)
(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-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))
(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))))
-(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))
- (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))
- (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)
())
+(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)))
"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)
+ (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)))
+ (break "here")
(setf (slot-value-using-class
(class-of obj)
obj
(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))
HCoop / clinton / lisp-on-lines.git / blobdiff