r3456: *** empty log message ***

diff --git a/example.lisp b/example.lisp
index 9398cc6f171247f22d95a34f0d8eaba58315808e..cc9883dd4cb7a9555e5631c805581da8209ec9ed 100644 (file)
--- a/example.lisp
+++ b/example.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; A simple example file for hyperobjects
 ;;;;
-;;;; $Id: example.lisp,v 1.2 2002/11/22 15:45:06 kevin Exp $
+;;;; $Id: example.lisp,v 1.3 2002/11/22 19:14:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -26,6 +26,7 @@
    (resume :type cdata :initarg :resume :reader resume)
    (addresses :initarg :addresses :reader addresses :initform nil :subobject t))
   (:metaclass hyperobject-class)
+  (:print-slots first-name last-name dob resume)
   (:title "Person"))
 
 (defun format-date (ut)
@@ -45,12 +46,14 @@
    (street :type string :initarg :street :reader street :initform nil)
    (phones :initarg :phones :reader phones :initform nil :subobject t))
   (:metaclass hyperobject-class)
-  (:title "Address"))
+  (:title "Address")
+  (:print-slots title street))
 
 (defclass phone (hyperobject)
   ((phone-number :type string :initarg :phone-number :reader phone-number))
   (:metaclass hyperobject-class)
-  (:title "Phone Number"))
+  (:title "Phone Number")
+  (:print-slots phone-number))
 
 
 (defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812"))

diff --git a/hyperobject.lisp b/hyperobject.lisp
index 921f6f8ad7c4fc6bbb051b44bc32ac425e8a2fef..70b67b12271d96f3ea1fba34c4dac73d22db2157 100644 (file)
--- a/hyperobject.lisp
+++ b/hyperobject.lisp
@@ -11,7 +11,7 @@
 ;;;; in Text, HTML, and XML formats. This includes hyperlinking
 ;;;; capability and sub-objects.
 ;;;;
-;;;; $Id: hyperobject.lisp,v 1.7 2002/11/22 16:05:08 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.8 2002/11/22 19:14:17 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -79,35 +79,34 @@
 ;; Main class
 
 (defclass hyperobject-class (standard-class)
-  ((title :initarg :title :type string :reader ml-std-title
-         :documentation 
-"Print Title for class")
+  ((title :initarg :title :type string :initform nil
+         :documentation "Print Title for class")
+   (print-slots :initarg :print-slots :type list :initform nil
+         :documentation "List of slots to print")
    (subobjects
-    :initarg :subobjects
-    :documentation 
-"List of fields that contain a list of subobjects objects.")
+    :initarg :subobjects :initform nil
+    :documentation "List of fields that contain a list of subobjects objects.")
    (references
-    :initarg :references :type list :reader ml-std-references
+    :initarg :references :type list :initform nil
     :documentation 
     "List of fields that can be referred to by browsers. 
 Format is ((field-name field-lookup-func other-link-params) ...)")
    
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
-   (value-func :initform nil :type function :reader ml-std-value-func)
-   (xmlvalue-func :initform nil :type function :reader ml-std-xmlvalue-func)
-   (fmtstr-text :initform nil :type string :reader ml-std-fmtstr-text)
-   (fmtstr-html :initform nil :type string :reader ml-std-fmtstr-html)
-   (fmtstr-xml :initform nil :type string :reader ml-std-fmtstr-xml)
-   (fmtstr-text-labels :initform nil :type string :reader ml-std-fmtstr-text-labels)
-   (fmtstr-html-labels :initform nil :type string :reader ml-std-fmtstr-html-labels)
-   (fmtstr-xml-labels :initform nil :type string :reader ml-std-fmtstr-xml-labels)
-   (fmtstr-html-ref :initform nil :type string :reader ml-std-fmtstr-html-ref)
-   (fmtstr-xml-ref :initform nil :type string :reader ml-std-fmtstr-xml-ref)
-   (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)
+   (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)
    )
-  (:default-initargs :title nil :subobjects nil :references nil)
   (:documentation "Metaclass for Markup Language classes."))
 
 (defclass subobject ()
@@ -152,6 +151,14 @@ 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 :print-slots))
+                                       value)
+  (if (null (cdr value))
+      (list name (car value))
+      (list name `',value)))
+
 (defmethod (compute-effective-slot-definition) :around
     ((cl hyperobject-class) #+(or allegro lispworks) slot dsds)
   (declare (ignorable slot))
@@ -189,7 +196,10 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
      ho-type)))
 
 ;;;; Class initialization function
-      
+
+(defun find-slot-by-name (cl name)
+  (find name (class-slots cl) :key #'slot-definition-name))
+               
 (defun init-hyperobject-class (cl)
     (let ((fmtstr-text "")
          (fmtstr-html "")
@@ -209,18 +219,22 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
          (references nil)
          (subobjects nil))
       (declare (ignore classname))
-      (dolist (f (class-slots cl))
-       (if (slot-value f 'subobject)
-           (push (make-instance 'subobject :name (slot-definition-name f)
-                                :reader (if (eq t (esd-subobject f))
-                                            (slot-definition-name f)
-                                            (esd-subobject f)))
+      
+      (dolist (slot-name (slot-value cl 'print-slots))
+       (let ((slot (find-slot-by-name cl slot-name)))
+         (unless slot
+           (error "Slot ~A is not found in class ~S" slot-name cl))
+         (if (slot-value slot 'subobject)
+           (push (make-instance 'subobject :name (slot-definition-name slot)
+                                :reader (if (eq t (esd-subobject slot))
+                                            (slot-definition-name slot)
+                                            (esd-subobject slot)))
                  subobjects)
-           (let ((name (slot-definition-name f))
-                 (namestr (symbol-name (slot-definition-name f)))
-                 (namestr-lower (string-downcase (symbol-name (slot-definition-name f))))
-                 (type (slot-value f 'ho-type))
-                 (formatter (slot-value f 'format-func))
+           (let ((name (slot-definition-name slot))
+                 (namestr (symbol-name (slot-definition-name slot)))
+                 (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
+                 (type (slot-value slot 'ho-type))
+                 (formatter (slot-value slot 'format-func))
                  (value-fmt "~a")
                  (plain-value-func nil)
                  html-str xml-str html-label-str xml-label-str)
@@ -260,13 +274,13 @@ 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 (esd-reference f)
+         (if (esd-reference slot)
              (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))
+               (push (make-instance 'reference :name name :lookup (esd-reference slot))
                      references))
              (progn
                (string-append fmtstr-html-ref html-str)
@@ -284,7 +298,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
          (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)))
-         )))
+         ))))
 
       (setf (slot-value cl 'references) references)
       (setf (slot-value cl 'subobjects) subobjects)