Commit 1adf1ba2 authored by ryszard.szopa's avatar ryszard.szopa
Browse files

file refactoring

darcs-hash:c3f629f6b65bd889d8fb408e12b61d1173760000
parent 02caa2ae
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(in-package :asdf)
(defpackage :submarine
(:use :cl :s-sql :cl-postgres :sb-mop :iterate))
(in-package :submarine)
;;
;; Utilities
;;
;;
(defun class-name-of (object)
"The class-name of the class of OBJECT."
(class-name (class-of object)))
(defun class-non-transient-slots (class)
"Return the list of non-transient slots of a class."
(remove-if #'transient-p (class-slots class)))
(defun slots-of (object)
"List of names of the slots of OBJECT."
(mapcar #'slot-definition-name (class-slots (class-of object))))
(defun non-transient-slots-of (object)
"List of names of non-transient slots of OBJECT."
(mapcar #'slot-definition-name (remove-if #'transient-p (class-slots (class-of object)))))
(defun slot-value-or-id-if-foreign (object slot)
"SLOT-VALUE if SLOT in OBJECT is not foreign, the ID of the object in the slot otherwise."
(let ((value (slot-value object slot)))
(or (and (typep value 'dao) (get-id value))
value)))
;;
;; MOP
;;
;;
(defclass db-class (standard-class)
((checked-schema-congruence :initform nil
:reader class-checked-schema-congruence-p)
(indices :initarg :indices :initform () :reader db-class-indices)))
(defmethod validate-superclass ((class db-class)
(superclass standard-class))
t)
(defclass db-class-slot-definition ()
((transient :initform nil :initarg :transient :accessor transient-p
:documentation
"Whether this slot should be treated as transient and
ignored in all database related operations.")))
(defclass db-class-direct-slot-definition
(standard-direct-slot-definition db-class-slot-definition)
())
(defclass db-class-effective-slot-definition
(db-class-slot-definition standard-effective-slot-definition)
())
;; Why we need this method is magic for me... I don't know why the
;; values of initargs are not propagated to the effective slots by
;; default... Copied form mopintro.
(defmethod compute-effective-slot-definition :around
((class db-class) slot-name direct-slot-definitions)
(let ((slotd (call-next-method)))
(setf (transient-p slotd) (every #'transient-p direct-slot-definitions))
slotd))
(defgeneric foreign-type-p (slot)
(:method ((slot db-class-slot-definition))
(typep (find-class (slot-definition-type slot)) 'db-class)))
(defmethod direct-slot-definition-class ((class db-class) &rest initargs)
(declare (ignore initargs))
;(call-next-method)
(find-class 'db-class-direct-slot-definition))
(defmethod effective-slot-definition-class ((class db-class) &rest initargs)
(declare (ignore initargs))
;(call-next-method)
(find-class 'db-class-effective-slot-definition))
(defmethod shared-initialize :after ((class db-class) slots &rest rest)
;; create the right table, or, if a table of the right name exists,
;; check whether it meets the spec. Alter it if this is not the
;; case.
(declare (ignore rest))
(finalize-inheritance class)
(unless (eq (class-name class) 'dao)
(create-table class)))
;;
;; Database stuff
......@@ -243,12 +153,6 @@ table ~A. This may indicate that something is wrong." (first column) (second col
(:documentation "Base class for any PostgreSQL aware classes."))
;; (defmethod shared-initialize ((instance dao) slots &rest rest)
;; ;; if id is provided, just get fill the slots from the database.
;; ;; otherwise, create a fresh one.
;; ;; If the
;; )
(defgeneric save-dao (object)
(:documentation "Save a dao: update it when it already exists, insert it otherwise.")
(:method ((dao dao))
......@@ -290,7 +194,7 @@ exists in the database.")
(:documentation "Update the dao's representation in the database
with the values in the given object."))
(defmethod update-dao ((dao class))
(defmethod update-dao ((dao dao))
(postmodern::execute (sql-compile
`(:update ,(class-name-of dao) :set ,@(set-fields dao)
:where (:= 'id (get-id dao))))))
......
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(in-package :submarine)
;;
;; MOP
;;
;;
(defclass db-class (standard-class)
((indices :initarg :indices :initform () :reader db-class-indices)))
(defmethod validate-superclass ((class db-class)
(superclass standard-class))
t)
(defclass db-class-slot-definition ()
((transient :initform nil :initarg :transient :accessor transient-p
:documentation
"Whether this slot should be treated as transient and
ignored in all database related operations.")))
(defclass db-class-direct-slot-definition
(standard-direct-slot-definition db-class-slot-definition)
())
(defclass db-class-effective-slot-definition
(db-class-slot-definition standard-effective-slot-definition)
())
;; Why we need this method is magic for me... I don't know why the
;; values of initargs are not propagated to the effective slots by
;; default... Copied form mopintro.
(defmethod compute-effective-slot-definition :around
((class db-class) slot-name direct-slot-definitions)
(let ((slotd (call-next-method)))
(setf (transient-p slotd) (every #'transient-p direct-slot-definitions))
slotd))
(defgeneric foreign-type-p (slot)
(:method ((slot db-class-slot-definition))
(typep (find-class (slot-definition-type slot)) 'db-class)))
(defmethod direct-slot-definition-class ((class db-class) &rest initargs)
(declare (ignore initargs))
(find-class 'db-class-direct-slot-definition))
(defmethod effective-slot-definition-class ((class db-class) &rest initargs)
(declare (ignore initargs))
(find-class 'db-class-effective-slot-definition))
(defmethod shared-initialize :after ((class db-class) slots &rest rest)
;; create the right table, or, if a table of the right name exists,
;; check whether it meets the spec. Alter it if this is not the
;; case.
(declare (ignore rest))
(finalize-inheritance class)
(unless (eq (class-name class) 'dao)
(create-table class)))
......@@ -6,7 +6,10 @@
(in-package :submarine-system)
(defsystem :submarine
:depends-on (:postmodern)
:depends-on (:postmodern :iterate)
:serial t
:components
((:file "package")
(:file "meta" :depends-on ("package"))))
\ No newline at end of file
(:file "utilities")
(:file "mop")
(:file "db")))
\ No newline at end of file
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; -*-
(in-package :submarine)
;;
;; Utilities
;;
;;
(defun class-name-of (object)
"The class-name of the class of OBJECT."
(class-name (class-of object)))
(defun class-non-transient-slots (class)
"Return the list of non-transient slots of a class."
(remove-if #'transient-p (class-slots class)))
(defun slots-of (object)
"List of names of the slots of OBJECT."
(mapcar #'slot-definition-name (class-slots (class-of object))))
(defun non-transient-slots-of (object)
"List of names of non-transient slots of OBJECT."
(mapcar #'slot-definition-name (remove-if #'transient-p (class-slots (class-of object)))))
(defun slot-value-or-id-if-foreign (object slot)
"SLOT-VALUE if SLOT in OBJECT is not foreign, the ID of the object in the slot otherwise."
(let ((value (slot-value object slot)))
(or (and (typep value 'dao) (get-id value))
value)))
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment