X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=84962823c874719170d5b8ba5ece212d0753c3f4;hb=21c4e5bd0f49bf0349ce0778fed676d05f11f78e;hp=1094c56f0fd4595ab9b97dc7db90a14f6be3bd71;hpb=da95022a6396191e772e59cd7622c7c5919ce605;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 1094c56..8496282 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.10 2002/12/13 05:44:19 kevin Exp $ +;;;; $Id: mop.lisp,v 1.13 2002/12/13 22:26:41 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -27,24 +27,34 @@ (defclass hyperobject-class (standard-class) ( ;; slots initialized in defclass (user-name :initarg :user-name :type string :initform nil - :documentation "User name for class") + :accessor user-name + :documentation "User name for class") (default-print-slots :initarg :default-print-slots :type list :initform nil + :accessor default-print-slots :documentation "Defaults slots for a view") (description :initarg :description :initform nil + :accessor description :documentation "Class description") (version :initarg :version :initform nil - :documentation "Version number for class") + :accessor version + :documentation "Version number for class") (sql-name :initarg :table-name :initform nil) ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. - (subobjects :initform nil :documentation + (subobjects :initform nil :accessor subobjects + :documentation "List of fields that contain a list of subobjects objects.") - (hyperlinks :type list :initform nil :documentation - "List of fields that have hyperlinks") - (class-id :type integer :initform nil :documentation - "Unique ID for the class") + (hyperlinks :type list :initform nil :accessor hyperlinks + :documentation "List of fields that have hyperlinks") + (direct-rules :type list :initform nil :accessor direct-rules + :documentation "List of rules to fire on slot changes.") + (class-id :type integer :initform nil + :accessor class-id + :documentation "Unique ID for the class") + (default-view :initform nil :initarg :default-view :accessor default-view + :documentation "The default view for a class") ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) @@ -53,8 +63,8 @@ (views :type list :initform nil :initarg :views :accessor views :documentation "List of views") - (default-view :initform nil :initarg :default-view :accessor default-view - :documentation "The default view for a class") + (rules :type list :initform nil :initarg :rules :accessor rules + :documentation "List of rules") ) (:documentation "Metaclass for Markup Language classes.")) @@ -138,7 +148,11 @@ `(,(intern (symbol-name x)) :initarg ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil)) + :initform nil + :accessor + ,(intern (concatenate 'string + (symbol-name :dsd-) + (symbol-name x))))) *slot-options*)))) (eval `(defclass hyperobject-esd (standard-effective-slot-definition) @@ -146,8 +160,12 @@ `(,(intern (symbol-name x)) :initarg ,(intern (symbol-name x) (symbol-name :keyword)) - :initform nil)) - (append *slot-options* *slot-options-no-initarg*))))) + :initform nil + :accessor + ,(intern (concatenate 'string + (symbol-name :esd-) + (symbol-name x))))) + (append *slot-options* *slot-options-no-initarg*))))) ) ;; eval-when (defun intern-in-keyword (obj) @@ -163,13 +181,15 @@ (t obj))) -(defmethod compute-effective-slot-definition :around - ((cl hyperobject-class) #+(or allegro lispworks) name dsds) +(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) + #+(or allegro lispworks) name + dsds) #+allergo (declare (ignore name)) (let* ((dsd (car dsds)) (ho-type (intern-in-keyword (slot-value dsd 'type))) (sql-type (ho-type-to-sql-type ho-type)) (length (when (consp ho-type) (cadr ho-type)))) + #+allergo (declare (ignore name)) (setf (slot-value dsd 'ho-type) ho-type) (setf (slot-value dsd 'sql-type) sql-type) (setf (slot-value dsd 'type) (ho-type-to-lisp-type ho-type)) @@ -187,6 +207,8 @@ :description (slot-value dsd 'description) :user-name (slot-value dsd 'user-name) :index (slot-value dsd 'index) + :value-constraint (slot-value dsd 'value-constraint) + :null-allowed (slot-value dsd 'null-allowed) ia)))) (defun ho-type-to-lisp-type (ho-type) @@ -257,10 +279,10 @@ (defun finalize-subobjects (cl) "Process class subobjects slot" - (setf (slot-value cl 'subobjects) + (setf (subobjects cl) (let ((subobjects '())) (dolist (slot (class-slots cl)) - (let-when (subobj-def (slot-value slot 'subobject)) + (let-when (subobj-def (esd-subobject slot)) (let ((subobject (make-instance 'subobject :name-class (class-name cl) :name-slot (slot-definition-name slot) @@ -293,13 +315,13 @@ (let ((*print-circle* nil)) (setf (documentation (class-name cl) 'class) (format nil "Hyperobject~A~A~A~A" - (aif (slot-value cl 'user-name) + (aif (user-name cl) (format nil ": ~A" it "")) - (aif (slot-value cl 'description) + (aif (description cl) (format nil "~%Class description: ~A" it) "") - (aif (slot-value cl 'subobjects) + (aif (subobjects cl) (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") - (aif (slot-value cl 'default-print-slots) + (aif (default-print-slots cl) (format nil "~%Default print slots:~{ ~A~}" it) "") )))) @@ -321,6 +343,7 @@ (finalize-views cl) (finalize-hyperlinks cl) (finalize-sql cl) + (finalize-rules cl) (finalize-documentation cl)) @@ -332,17 +355,69 @@ (find name (class-slots cl) :key #'slot-definition-name)) (defun hyperobject-class-user-name (obj) - (awhen (slot-value (class-of obj) 'user-name) + (awhen (user-name (class-of obj)) (if (consp it) (car it) it))) (defun hyperobject-class-subobjects (obj) - (slot-value (class-of obj) 'subobjects)) + (subobjects (class-of obj))) (defun hyperobject-class-hyperlinks (obj) - (slot-value (class-of obj) 'hyperlinks)) + (hyperlinks (class-of obj))) (defun hyperobject-class-fields (obj) (class-slots (class-of obj))) +;;; Slot accessor and class rules + +(defclass rule () + ((dependants :initarg dependants :initform nil :accessor dependants) + (volatile :initarg modifieds :initform nil :accessor modifieds) + (source-code :initarg source-code :initform nil :accessor source-code) + (function :initform nil :accessor function))) + +(defun compile-rule (source-code cl) + ) + +(defun finalize-rules (cl) + (let* ((direct-rules (direct-rules cl)) + (rule-vector (make-vector (length direct-rules) :fill-pointer nil + :adjustable nil))) + (dotimes (i (length direct-rules)) + (destructuring-bind (name (&key dependants volatile) &rest source-code) + (nth i direct-rules) + (setf (aref rule-vector i) (make-instance 'rule + :name name + :dependants depedenants + :volatile volatile + :source-code source-code + :function (compile-rule source-code cl))))) + (setf (rules cl) rule-vector))) + +(defun fire-class-rules (cl obj) + "Fire all class rules. Called after a slot is modified." + (dolist (rule (direct-rules cl)) + (cmsg "firing rule: ~a" rule))) + + +(defmethod (setf slot-value-using-class) + :around (new-value (cl hyperobject-class) obj + (slot standard-effective-slot-definition)) + (cmsg-c :verbose "Setf slot value: class: ~s, obj: ~s, slot: ~s, value: ~s" cl (class-of obj) slot new-value) + (let ((func (esd-value-constraint slot))) + (cond + ((and func (not (funcall func new-value obj))) + (warn "Rejected change to value of slot ~a of object ~a" + (slot-definition-name slot) obj) + (slot-value obj (slot-definition-name slot))) + (t + (call-next-method) + (fire-class-rules cl obj) + new-value)))) + +(defmethod slot-value-using-class :around ((cl hyperobject-class) obj + (slot standard-effective-slot-definition)) + (let ((value (call-next-method))) + (cmsg-c :verbose "slot value: class: ~s, obj: ~s, slot: ~s" cl (class-of obj) slot) + value))