r3453: *** empty log message ***

diff --git a/hyperobject-mop.lisp b/hyperobject-mop.lisp
index affddc85d17797e88b993e113806ad5dbea87806..9f3113a4ac4ea48705b5e795e7b1f7c778c452bd 100644 (file)
--- a/hyperobject-mop.lisp
+++ b/hyperobject-mop.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: hyperobject-mop.lisp,v 1.2 2002/11/22 12:16:03 kevin Exp $
+;;;; $Id: hyperobject-mop.lisp,v 1.3 2002/11/22 14:58:16 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -36,6 +36,18 @@
   #+sbcl (sb-pcl:class-name obj)
   #+cmu (pcl:class-name obj))
 
+(defun portable-class-slots (obj)
+  #+allegro (mop:class-slots obj)
+  #+lispworks (clos:class-slots obj)
+  #+sbcl (sb-pcl:class-slots obj)
+  #+(or cmu scl) (pcl:class-slots obj))
+
+(defun portable-slot-name (obj)
+  #+allegro (mop::slot-definition-name obj)
+  #+lispworks (clos::slot-definition-name obj)
+  #+sbcl (sb-pcl::slot-definition-name obj)
+  #+(or cmu scl) (pcl::slot-definition-name obj))
+
 
 ;; Slot definitions
 
@@ -47,9 +59,9 @@
                           #+(or scl cmucl) pcl::standard-direct-slot-definition
                           )
   ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type)
+   (format-func :initarg :format-func :initform nil :accessor dsd-format-func)
    (subobject :initarg :subobject :initform nil :accessor dsd-subobject)
    (reference :initarg :reference :initform nil :accessor dsd-reference)
-   (format-func :initarg :format-func :initform nil :accessor dsd-format-func)
    ))
 
 (defclass hyperobject-esd (#+allegro mop::standard-effective-slot-definition
@@ -58,9 +70,9 @@
                           #+(or scl cmucl) pcl::standard-effective-slot-definition
                           )
   ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type)
-   (suboject :initarg :subobject :initform nil :accessor esd-subobject)
-   (reference :initarg :reference :initform nil :accessor esd-reference)
    (format-func :initarg :format-func :initform nil :accessor esd-format-func)
+   (subobject :initarg :subobject :initform nil :accessor esd-subobject)
+   (reference :initarg :reference :initform nil :accessor esd-reference)
   ))
 
 ;; Main class
@@ -71,16 +83,12 @@
   ((title :initarg :title :type string :reader ml-std-title
          :documentation 
 "Print Title for class")
-   (fields :initarg :fields :reader ml-std-fields
-          :documentation
-"List of field lists for printing. Format is 
-   ((fieldname type optional-formatter) ... )")
-   (subobjects-lists 
-    :initarg :subobjects-lists :reader ml-std-subobjects-lists
+   (subobjects
+    :initarg :subobjects
     :documentation 
 "List of fields that contain a list of subobjects objects.")
-   (ref-fields 
-    :initarg :ref-fields :type list :reader ml-std-ref-field
+   (references
+    :initarg :references :type list :reader ml-std-references
     :documentation 
     "List of fields that can be referred to by browsers. 
 Format is ((field-name field-lookup-func other-link-params) ...)")
@@ -100,9 +108,26 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
    (fmtstr-html-ref-labels :initform nil :type string :reader ml-std-fmtstr-html-ref-labels)
    (fmtstr-xml-ref-labels :initform nil :type string :reader ml-std-fmtstr-xml-ref-labels)
    )
-  (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
+  (:default-initargs :title nil :subobjects nil :references nil)
   (:documentation "Metaclass for Markup Language classes."))
 
+(defclass subobject ()
+  ((name :type symbol :initform nil :initarg :name :reader name)
+   (reader :type function :initform nil :initarg :reader :reader reader)))
+
+(defmethod print-object ((obj subobject) (s stream))
+  (print-unreadable-object (obj s :type t :identity t)
+    (format s "~S" (name obj))))
+
+(defclass reference ()
+  ((name :type symbol :initform nil :initarg :name :reader name)
+   (lookup :type function :initform nil :initarg :lookup :reader lookup)
+   (link-parameters :type list :initform nil :initarg :link-parameters
+                   :reader link-parameters)))
+
+(defmethod print-object ((obj reference) (s stream))
+  (print-unreadable-object (obj s :type t :identity t)
+    (format s "~S" (name obj))))
 
 #+cmu
 (defmethod pcl:finalize-inheritance :after ((cl hyperobject-class))
@@ -169,37 +194,12 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
       (list name (car value))
     (list name `',value)))
 
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-                                       (name (eql :fields))
-                                       value)
-  (unless value
-    (error "hyperobject-class fields must have a value"))
-  (list name `',value))
-
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-                                       (name (eql :ref-fields))
-                                       value)
-  (unless value
-    (error "hyperobject-class ref-fields must have a value"))
-  (list name `',value))
-
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-                                       (name (eql :subobjects-lists))
-                                       value)
-  (unless value
-    (error "hyperobject-class subobjects-lists must have a value"))
-  (list name `',value))
-
 (defmethod 
     #+allegro clos:compute-effective-slot-definition 
     #+lispworks clos:compute-effective-slot-definition 
     #+sbcl sb-pcl::compute-effective-slot-definition 
     #+(or cmucl scl) pcl::compute-effective-slot-definition 
-    :around
-          ((cl hyperobject-class) slot dsds)
+    :around ((cl hyperobject-class) #+(or allegro lispworks) slot dsds)
   (declare (ignorable slot))
   (let* ((dsd (car dsds))
         (ho-type (slot-value dsd 'type)))
@@ -208,12 +208,15 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
     (let ((ia 
           #+allegro (excl::compute-effective-slot-definition-initargs cl dsds)
           #+lispworks (clos::compute-effective-slot-definition-initargs cl slot dsds)
-          #+sbcl (sb-cl::compute-effective-slot-definition-initargs cl slot dsds)
-          #+(or cmucl scl) (pcl::compute-effective-slot-definition-initargs cl slot dsds)
+          #+sbcl (sb-pcl::compute-effective-slot-definition-initargs cl dsds)
+          #+(or cmucl scl) (pcl::compute-effective-slot-definition-initargs cl dsds)
           ))
       (apply
        #'make-instance 'hyperobject-esd 
        :ho-type ho-type
+       :format-func (slot-value dsd 'format-func)
+       :subobject (slot-value dsd 'subobject)
+       :reference (slot-value dsd 'reference)
        ia)))
   )
 
@@ -251,48 +254,55 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
          (first-field t)
          (value-func '())
          (xmlvalue-func '())
-         (classname (class-name cl))
+         (classname (portable-class-name cl))
          (package (symbol-package (portable-class-name cl)))
-         (ref-fields (slot-value cl 'ref-fields)))
+         (references nil)
+         (subobjects nil))
       (declare (ignore classname))
-      (dolist (f (slot-value cl 'fields))
-       (let ((name (car f))
-             (namestr (symbol-name (car f)))
-             (namestr-lower (string-downcase (symbol-name (car f))))
-             (type (cadr f))
-             (formatter (caddr f))
-             (value-fmt "~a")
-             (plain-value-func nil)
-             html-str xml-str html-label-str xml-label-str)
-         
-         (when (or (eql type :integer) (eql type :fixnum))
-           (setq value-fmt "~d"))
-         
-         (when (eql type :commainteger)
-           (setq value-fmt "~:d"))
-         
-         (when (eql type :boolean)
-           (setq value-fmt "~a"))
-           
-         (if first-field
-             (setq first-field nil)
-           (progn
-             (string-append fmtstr-text " ")
-             (string-append fmtstr-html " ")
-             (string-append fmtstr-xml " ")
-             (string-append fmtstr-text-labels " ")
-             (string-append fmtstr-html-labels " ")
-             (string-append fmtstr-xml-labels " ")
-             (string-append fmtstr-html-ref " ")
-             (string-append fmtstr-xml-ref " ")
-             (string-append fmtstr-html-ref-labels " ")
-             (string-append fmtstr-xml-ref-labels " ")))
-         
-         (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
-         (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-         (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
-         (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
-         
+      (dolist (f (portable-class-slots cl))
+       (if (slot-value f 'subobject)
+           (push (make-instance 'subobject :name (portable-slot-name f)
+                                :reader (if (eq t (esd-subobject f))
+                                            (portable-slot-name f)
+                                            (esd-subobject f)))
+                 subobjects)
+           (let ((name (portable-slot-name f))
+                 (namestr (symbol-name (portable-slot-name f)))
+                 (namestr-lower (string-downcase (symbol-name (portable-slot-name f))))
+                 (type (slot-value f 'ho-type))
+                 (formatter (slot-value f 'format-func))
+                 (value-fmt "~a")
+                 (plain-value-func nil)
+                 html-str xml-str html-label-str xml-label-str)
+             
+             (when (or (eql type :integer) (eql type :fixnum))
+               (setq value-fmt "~d"))
+             
+             (when (eql type :commainteger)
+               (setq value-fmt "~:d"))
+             
+             (when (eql type :boolean)
+               (setq value-fmt "~a"))
+             
+             (if first-field
+                 (setq first-field nil)
+                 (progn
+                   (string-append fmtstr-text " ")
+                   (string-append fmtstr-html " ")
+                   (string-append fmtstr-xml " ")
+                   (string-append fmtstr-text-labels " ")
+                   (string-append fmtstr-html-labels " ")
+                   (string-append fmtstr-xml-labels " ")
+                   (string-append fmtstr-html-ref " ")
+                   (string-append fmtstr-xml-ref " ")
+                   (string-append fmtstr-html-ref-labels " ")
+                   (string-append fmtstr-xml-ref-labels " ")))
+             
+             (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
+             (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+             (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
+             (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+             
          (string-append fmtstr-text value-fmt)
          (string-append fmtstr-html html-str)
          (string-append fmtstr-xml xml-str)
@@ -300,29 +310,34 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
          (string-append fmtstr-html-labels html-label-str)
          (string-append fmtstr-xml-labels xml-label-str)
          
-         (if (find name ref-fields :key #'car)
-           (progn
-             (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
-             (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
-             (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
-             (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>"))
-           (progn
-             (string-append fmtstr-html-ref html-str)
-             (string-append fmtstr-xml-ref xml-str)
-             (string-append fmtstr-html-ref-labels html-label-str)
-             (string-append fmtstr-xml-ref-labels xml-label-str)))
+         (if (esd-reference f)
+             (progn
+               (string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
+               (string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
+               (string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
+               (string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
+               (push (make-instance 'reference :name name :lookup (esd-reference f))
+                     references))
+             (progn
+               (string-append fmtstr-html-ref html-str)
+               (string-append fmtstr-xml-ref xml-str)
+               (string-append fmtstr-html-ref-labels html-label-str)
+               (string-append fmtstr-xml-ref-labels xml-label-str)))
          
          (if formatter
              (setq plain-value-func 
-               (list `(,formatter (,(intern namestr package) x))))
-           (setq plain-value-func 
-             (list `(,(intern namestr package) x))))
+                   (list `(,formatter (,(intern namestr package) x))))
+             (setq plain-value-func 
+                   (list `(,(intern namestr package) x))))
          (setq value-func (append value-func plain-value-func))
          
          (if (eql type :cdata)
              (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
-           (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
-         ))
+             (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
+         )))
+
+      (setf (slot-value cl 'references) references)
+      (setf (slot-value cl 'subobjects) subobjects)
       
       (if value-func
          (setq value-func `(lambda (x) (values ,@value-func)))
@@ -380,14 +395,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
                (car it)
              it))))
 
-(defun hyperobject-class-subobjects-lists (obj)
-  (slot-value (portable-class-of obj) 'subobjects-lists))
+(defun hyperobject-class-subobjects (obj)
+  (slot-value (portable-class-of obj) 'subobjects))
 
-(defun hyperobject-class-ref-fields (obj)
-  (slot-value (portable-class-of obj) 'ref-fields))
+(defun hyperobject-class-references (obj)
+  (slot-value (portable-class-of obj) 'references))
 
 (defun hyperobject-class-fields (obj)
-  (slot-value (portable-class-of obj) 'fields))
+  (portable-class-slots (portable-class-of obj)))
 
 (defun hyperobject-class-fmtstr-html-ref (obj)
   (slot-value (portable-class-of obj) 'fmtstr-html-ref))
@@ -745,12 +760,16 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
          (funcall (funcall (obj-data-value-func fmt) x) x))))
     
     ;; make list of reference link fields for printing to refstr template
-    (dolist (field (hyperobject-class-ref-fields x))
+    (dolist (ref (hyperobject-class-references x))
       (let ((link-start 
-            (make-link-start x (link-ref fmt) (car field) (cadr field)
-                             (nth (position (car field) (hyperobject-class-fields x) :key #'car) field-values)  
-                             (append (caddr field) refvars)))
-           (link-end (make-link-end x (link-ref fmt) (car field))))
+            (make-link-start x (link-ref fmt) (name ref) (lookup ref)
+                             (nth (position (name ref)
+                                            (hyperobject-class-fields x)
+                                            :key #'(lambda (x)
+                                                     (portable-slot-name x)))
+                                  field-values)  
+                             (append (link-parameters ref) refvars)))
+           (link-end (make-link-end x (link-ref fmt) (name ref))))
        (push link-start refvalues)
        (push link-end refvalues)))
     (setq refvalues (nreverse refvalues))
@@ -788,9 +807,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
   (when objs
     (let ((objlist (mklist objs)))
       (dolist (obj objlist)
-        (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
+        (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
           (dolist (child-obj it)   ;; for each child function
-            (awhen (funcall (car child-obj) obj)
+            (awhen (funcall (reader child-obj) obj)
               (load-all-subobjects it))))))
     objs))
 
@@ -814,9 +833,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
           (fmt-obj-start obj fmt strm indent)
           (fmt-obj-data obj fmt strm (1+ indent) label refvars)
           (if subobjects
-              (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
+              (awhen (hyperobject-class-subobjects obj)  ;; access list of functions
                         (dolist (child-obj it)   ;; for each child function
-                          (awhen (funcall (car child-obj) obj) ;; access set of child objects
+                          (awhen (funcall (reader child-obj) obj) ;; access set of child objects
                                     (print-hyperobject-class it fmt strm label 
                                                      (1+ indent) english-only-function
                                                     subobjects refvars)))))
@@ -849,7 +868,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
   (print-unreadable-object (obj s :type t :identity t)
     (let ((fmt (make-instance 'hyperobject::textformat)))
       (apply #'format 
-            s (funcall (hyperobject::obj-data-fmtstr fmt) obj)
+            s (funcall (hyperobject-mop::obj-data-fmtstr fmt) obj)
             (multiple-value-list 
-             (funcall (funcall (hyperobject::obj-data-value-func fmt) obj) obj))))))
+             (funcall (funcall (hyperobject-mop::obj-data-value-func fmt) obj) obj))))))
 

diff --git a/mop-example.lisp b/mop-example.lisp
index ce275d52f4a6e6dc5e666d46a48d7528313f7f24..278d4a7813f0fd673f3b81ff33a30dcdc701d5c8 100644 (file)
--- a/mop-example.lisp
+++ b/mop-example.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; A simple example file for hyperobjects
 ;;;;
-;;;; $Id: mop-example.lisp,v 1.1 2002/11/22 10:49:24 kevin Exp $
+;;;; $Id: mop-example.lisp,v 1.2 2002/11/22 14:58:16 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -19,19 +19,14 @@
 
 
 (defclass person (hyperobject)
-  ((first-name :type string :initarg :first-name :reader first-name)
-   (last-name :type string :initarg :last-name :reader last-name)
-   (dob :type integer :initarg :dob :reader dob)
-   (resume :initarg :resume :reader resume)
-   (addresses :initarg :addresses :reader addresses))
+  ((first-name :type string :initarg :first-name :reader first-name :initform nil)
+   (last-name :type string :initarg :last-name :reader last-name :initform nil
+             :reference find-person-by-last-name)
+   (dob :type integer :initarg :dob :reader dob :initform 0 :format-func format-date)
+   (resume :type cdata :initarg :resume :reader resume)
+   (addresses :initarg :addresses :reader addresses :initform nil :subobject t))
   (:metaclass hyperobject-class)
-  (:default-initargs 
-   :first-name nil :last-name nil :resume nil :dob 0 :addresses nil)
-  (:title "Person")
-  (:subobjects-lists (addresses address))
-  (:fields (first-name  :string) (last-name :string) (dob :integer format-date)
-          (resume :cdata))
-  (:ref-fields (last-name find-person-by-last-name)))
+  (:title "Person"))
 
 (defun format-date (ut)
   (when (typep ut 'integer)
@@ -46,21 +41,16 @@
                hr min sec))))
 
 (defclass address (hyperobject)
-  ((title :type string :initarg :title :reader title)
-   (street :type string :initarg :street :reader street)
-   (phones :initarg :phones :reader phones))
+  ((title :type string :initarg :title :reader title :initform nil)
+   (street :type string :initarg :street :reader street :initform nil)
+   (phones :initarg :phones :reader phones :initform nil :subobject t))
   (:metaclass hyperobject-class)
-  (:default-initargs :title nil :street nil :phones nil)
-  (:title "Address")
-  (:subobjects-lists (phones phone))
-  (:fields (title :string) (street  :string)))
-
+  (:title "Address"))
 
 (defclass phone (hyperobject)
   ((phone-number :type string :initarg :phone-number :reader phone-number))
   (:metaclass hyperobject-class)
-  (:title "Phone Number")
-  (:fields (phone-number :string)))
+  (:title "Phone Number"))
 
 
 (defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812"))