X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=9f66bf289034d23229a4debd35392722dfad11ca;hb=6cfefea96a65eb54d12d10e61a1d2b9ecaddc8ae;hp=3505a1bdf754c72113855cebbd510907d3e89cbc;hpb=90c2e4c13bd89c48de9fe0da126547447b7b9e01;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 3505a1b..9f66bf2 100644 --- a/mop.lisp +++ b/mop.lisp @@ -62,7 +62,7 @@ (direct-views :type list :initform nil :initarg :direct-views :accessor direct-views :documentation "List of views") - (class-id :type integer :initform nil + (class-id :type integer :initform (+ (* 1000000 (get-universal-time)) (random 1000000)) :accessor class-id :documentation "Unique ID for the class") (default-view :initform nil :initarg :default-view :accessor default-view @@ -125,8 +125,100 @@ (defmethod validate-superclass ((class hyperobject-class) (superclass standard-class)) t) + +(declaim (inline delistify)) +(defun delistify (list) + "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." + (if (listp list) + (car list) + list)) + +(defun remove-keyword-arg (arglist akey) + (let ((mylist arglist) + (newlist ())) + (labels ((pop-arg (alist) + (let ((arg (pop alist)) + (val (pop alist))) + (unless (equal arg akey) + (setf newlist (append (list arg val) newlist))) + (when alist (pop-arg alist))))) + (pop-arg mylist)) + newlist)) + +(defun remove-keyword-args (arglist akeys) + (let ((mylist arglist) + (newlist ())) + (labels ((pop-arg (alist) + (let ((arg (pop alist)) + (val (pop alist))) + (unless (find arg akeys) + (setf newlist (append (list arg val) newlist))) + (when alist (pop-arg alist))))) + (pop-arg mylist)) + newlist)) + + +(defmethod shared-initialize :around ((class hyperobject-class) slot-names + &rest initargs + &key direct-superclasses + user-name sql-name name description + &allow-other-keys) + ;(format t "ii ~S ~S ~S ~S ~S~%" initargs base-table direct-superclasses user-name sql-name) + (let ((root-class (find-class 'hyperobject nil)) + (vmc 'hyperobject-class) + user-name-plural user-name-str sql-name-str) + ;; when does CLSQL pass :qualifier to initialize instance? + (setq user-name-str + (if user-name + (delistify user-name) + (and name (format nil "~:(~A~)" name)))) + + (setq sql-name-str + (if sql-name + (delistify sql-name) + (and name (lisp-name-to-sql-name name)))) + + (if sql-name + (delistify sql-name) + (and name (lisp-name-to-sql-name name))) + + (setq description (delistify description)) + + (setq user-name-plural + (if (and (consp user-name) (second user-name)) + (second user-name) + (and user-name-str (format nil "~A~P" user-name-str 2)))) + + (flet ((do-call-next-method (direct-superclasses) + (let ((fn-args (list class slot-names :direct-superclasses direct-superclasses)) + (rm-args '(:direct-superclasses))) + (when user-name-str + (setq fn-args (nconc fn-args (list :user-name user-name-str))) + (push :user-name rm-args)) + (when user-name-plural + (setq fn-args (nconc fn-args (list :user-name-plural user-name-plural))) + (push :user-name-plural rm-args)) + (when sql-name-str + (setq fn-args (nconc fn-args (list :sql-name sql-name-str))) + (push :sql-name rm-args)) + (when description + (setq fn-args (nconc fn-args (list :description description))) + (push :description rm-args)) + (setq fn-args (nconc fn-args (remove-keyword-args initargs rm-args))) + (apply #'call-next-method fn-args)))) + (if root-class + (if (some #'(lambda (super) (typep super vmc)) + direct-superclasses) + (do-call-next-method direct-superclasses) + (do-call-next-method direct-superclasses #+nil (append (list root-class) + direct-superclasses))) + (do-call-next-method direct-superclasses))))) + + (defmethod finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) + "Initialize a hyperobject class. Calculates all class slots" + (finalize-subobjects cl) + (finalize-compute-cached cl)) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list @@ -241,21 +333,6 @@ (t t))) -(defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs) - (do* ((parsed (list obj)) - (name (first initargs) (first initargs)) - (val (second initargs) (second initargs))) - ((null initargs) - (apply #'call-next-method parsed)) - (if (eql name :value-type) - (progn - (setq val (canonicalize-value-type val)) - (setq parsed (append parsed (list name val))) - (setq parsed (append parsed (list :type - (value-type-to-lisp-type - (canonicalize-value-type val)))))) - (setq parsed (append parsed (list name val)))) - (setq initargs (cddr initargs)))) (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name @@ -446,32 +523,9 @@ SQL name" (store-lazily-computed-objects cl 'subobjects 'esd-subobject 'subobject)) (defun finalize-compute-cached (cl) - (store-lazily-computed-objects cl 'compute-cached-values + (store-lazily-computed-objects cl 'compute-cached-values 'esd-compute-cached-value 'compute-cached-value)) -(defun finalize-class-slots (cl) - "Make sure all class slots have an expected value" - (unless (user-name cl) - (setf (user-name cl) (format nil "~:(~A~)" (class-name cl)))) - - (setf (user-name-plural cl) - (if (and (consp (user-name cl)) (cadr (user-name cl))) - (cadr (user-name cl)) - (format nil "~A~P" (if (consp (user-name cl)) - (car (user-name cl)) - (user-name cl)) - 2))) - - (dolist (name '(user-name description version guid sql-name)) - (awhen (slot-value cl name) - (setf (slot-value cl name) - (if (listp it) - (car it) - it)))) - - (unless (sql-name cl) - (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl)))) - ) (defun finalize-documentation (cl) "Calculate class documentation slot" @@ -505,16 +559,15 @@ SQL name" (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" - (finalize-subobjects cl) - (finalize-compute-cached cl) (finalize-views cl) (finalize-hyperlinks cl) (finalize-sql cl) (finalize-rules cl) - (finalize-class-slots cl) (finalize-documentation cl)) + + ;;;; ************************************************************************* ;;;; Metaclass Slot Accessors ;;;; *************************************************************************