X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=84962823c874719170d5b8ba5ece212d0753c3f4;hb=21c4e5bd0f49bf0349ce0778fed676d05f11f78e;hp=327c76bd259c8f995ec5953ee2d58795898274df;hpb=9e616a490d6d4f03682a7bd7e9ea6587fecf2015;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 327c76b..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.8 2002/12/09 10:39:38 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,41 +27,44 @@ (defclass hyperobject-class (standard-class) ( ;; slots initialized in defclass (user-name :initarg :user-name :type string :initform nil - :documentation "User name for class") - (print-slots :initarg :print-slots :type list :initform nil - :documentation "List of slots to print") + :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) (create-indices-cmds :initform nil :reader create-index-cmds) (drop-table-cmd :initform nil :reader drop-table-cmd) - (value-func :initform nil :type function) - (xmlvalue-func :initform nil :type function) - (fmtstr-text :initform nil :type string) - (fmtstr-html :initform nil :type string) - (fmtstr-xml :initform nil :type string) - (fmtstr-text-labels :initform nil :type string) - (fmtstr-html-labels :initform nil :type string) - (fmtstr-xml-labels :initform nil :type string) - (fmtstr-html-ref :initform nil :type string) - (fmtstr-xml-ref :initform nil :type string) - (fmtstr-html-ref-labels :initform nil :type string) - (fmtstr-xml-ref-labels :initform nil :type string) + (views :type list :initform nil :initarg :views :accessor views + :documentation "List of views") + (rules :type list :initform nil :initarg :rules :accessor rules + :documentation "List of rules") ) (:documentation "Metaclass for Markup Language classes.")) @@ -93,7 +96,8 @@ t) (defmethod finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) + (init-hyperobject-class cl) + ) ;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) @@ -144,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) @@ -152,17 +160,36 @@ `(,(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 - -(defmethod compute-effective-slot-definition :around - ((cl hyperobject-class) #+(or allegro lispworks) name dsds) + +(defun intern-in-keyword (obj) + (cond + ((null obj) + nil) + ((eq t obj) + t) + ((atom obj) + (intern (symbol-name obj) (find-package 'keyword))) + ((consp obj) + (cons (intern-in-keyword (car obj) ) (intern-in-keyword (cdr obj)))) + (t + obj))) + +(defmethod compute-effective-slot-definition :around ((cl hyperobject-class) + #+(or allegro lispworks) name + dsds) #+allergo (declare (ignore name)) (let* ((dsd (car dsds)) - (ho-type (slot-value dsd 'type)) + (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)) @@ -180,13 +207,15 @@ :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) (when (consp ho-type) (setq ho-type (car ho-type))) (check-type ho-type symbol) - (case (intern (symbol-name ho-type) (symbol-name :keyword)) + (case ho-type ((or :string :cdata :varchar :char) 'string) (:character @@ -201,7 +230,7 @@ 'single-float) (:double-float 'double-float) - (:nil + (nil t) (otherwise ho-type))) @@ -210,7 +239,7 @@ (when (consp ho-type) (setq ho-type (car ho-type))) (check-type ho-type symbol) - (case (intern (symbol-name ho-type) (symbol-name :keyword)) + (case ho-type ((or :string :cdata) 'string) (:fixnum @@ -223,7 +252,7 @@ 'single-float) (:double-float 'double-float) - (:nil + (nil t) (otherwise ho-type))) @@ -250,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) @@ -286,22 +315,35 @@ (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 'print-slots) - (format nil "~%Print-slots:~{ ~A~}" it) "") + (aif (default-print-slots cl) + (format nil "~%Default print slots:~{ ~A~}" it) "") )))) +(defun finalize-hyperlinks (cl) + (let ((hyperlinks '())) + (dolist (esd (class-slots cl)) + (awhen (slot-value esd 'hyperlink) + (push + (make-instance 'hyperlink + :name (slot-definition-name esd) + :lookup it + :link-parameters (slot-value esd 'hyperlink-parameters)) + hyperlinks))) + (setf (slot-value cl 'hyperlinks) hyperlinks))) + (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" (finalize-subobjects cl) (finalize-views cl) (finalize-hyperlinks cl) (finalize-sql cl) + (finalize-rules cl) (finalize-documentation cl)) @@ -312,59 +354,70 @@ (defun find-slot-by-name (cl name) (find name (class-slots cl) :key #'slot-definition-name)) -(defun hyperobject-class-fmtstr-text (obj) - (slot-value (class-of obj) 'fmtstr-text)) - -(defun hyperobject-class-fmtstr-html (obj) - (slot-value (class-of obj) 'fmtstr-html)) - -(defun hyperobject-class-fmtstr-xml (obj) - (slot-value (class-of obj) 'fmtstr-xml)) - -(defun hyperobject-class-fmtstr-text-labels (obj) - (slot-value (class-of obj) 'fmtstr-text-labels)) - -(defun hyperobject-class-fmtstr-html-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-labels)) - -(defun hyperobject-class-fmtstr-xml-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-labels)) - -(defun hyperobject-class-value-func (obj) - (slot-value (class-of obj) 'value-func)) - -(defun hyperobject-class-xmlvalue-func (obj) - (slot-value (class-of obj) 'xmlvalue-func)) - -(eval-when (:compile-toplevel :load-toplevel :execute) - - (defun hyperobject-class-user-name (obj) - (awhen (slot-value (class-of obj) 'user-name) - (if (consp it) - (car it) - it)))) +(defun hyperobject-class-user-name (obj) + (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))) -(defun hyperobject-class-print-slots (obj) - (slot-value (class-of obj) 'print-slots)) +;;; Slot accessor and class rules -(defun hyperobject-class-fmtstr-html-ref (obj) - (slot-value (class-of obj) 'fmtstr-html-ref)) - -(defun hyperobject-class-fmtstr-xml-ref (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref)) - -(defun hyperobject-class-fmtstr-html-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-ref-labels)) - -(defun hyperobject-class-fmtstr-xml-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) +(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))