r3468: *** empty log message ***

diff --git a/example.lisp b/example.lisp
index 39a884be6bae84599fbb1a39aa90439d7efaf347..e16bba54835954ff78f905ec240ebbe67a40410e 100644 (file)
--- a/example.lisp
+++ b/example.lisp
@@ -9,7 +9,7 @@
 ;;;;
 ;;;; A simple example file for hyperobjects
 ;;;;
-;;;; $Id: example.lisp,v 1.5 2002/11/23 18:41:45 kevin Exp $
+;;;; $Id: example.lisp,v 1.6 2002/11/24 17:47:50 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -28,7 +28,8 @@
   (:metaclass hyperobject-class)
   (:default-initargs :first-name nil :last-name nil :dob 0 :resume nil) 
   (:print-slots first-name last-name dob resume)
-  (:title "Person"))
+  (:title "Person")
+  (:description "A Person"))
 
 (defun format-date (ut)
   (when (typep ut 'integer)
@@ -49,22 +50,25 @@
   (:metaclass hyperobject-class)
   (:default-initargs :title nil :street nil) 
   (:title "Address")
-  (:print-slots title street))
+  (:print-slots title street)
+  (:description "An address"))
 
 (defclass phone (hyperobject)
-  ((phone-number :type string :initarg :phone-number :reader phone-number))
+  ((title :type string :initarg :title :reader title)
+   (phone-number :type string :initarg :phone-number :reader phone-number))
   (:metaclass hyperobject-class)
   (:title "Phone Number")
-  (:default-initargs :phone-number nil)
-  (:print-slots phone-number))
+  (:default-initargs :title nil :phone-number nil)
+  (:print-slots title phone-number)
+  (:description "A phone number"))
 
 
-(defparameter home-phone-1 (make-instance 'phone :phone-number "367-9812"))
-(defparameter home-phone-2 (make-instance 'phone :phone-number "367-9813"))
+(defparameter home-phone-1 (make-instance 'phone :title "Voice" :phone-number "367-9812"))
+(defparameter home-phone-2 (make-instance 'phone :title "Fax" :phone-number "367-9813"))
 
-(defparameter office-phone-1 (make-instance 'phone :phone-number "123-0001"))
-(defparameter office-phone-2 (make-instance 'phone :phone-number "123-0002"))
-(defparameter office-phone-3 (make-instance 'phone :phone-number "123-0005"))
+(defparameter office-phone-1 (make-instance 'phone :title "Main line" :phone-number "123-0001"))
+(defparameter office-phone-2 (make-instance 'phone :title "Staff line" :phone-number "123-0002"))
+(defparameter office-phone-3 (make-instance 'phone :title "Fax" :phone-number "123-0005"))
 
 (defparameter home (make-instance 'address :title "Home" :street "321 Shady Lane"
                                  :phones (list home-phone-1 home-phone-2)))

diff --git a/hyperobject.lisp b/hyperobject.lisp
index 454e57ffc7bcbace8f43bba6d2d0a30cd5a6f256..34a60a9d774c62ba738e1dc79b91949012b08616 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.11 2002/11/23 22:19:17 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.12 2002/11/24 17:47:50 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -54,10 +54,11 @@
 
 
 (defclass hyperobject-dsd (standard-direct-slot-definition)
-  ((ho-type :initarg :ho-type :initform nil :accessor dsd-ho-type)
-   (print-formatter :initarg :print-formatter :initform nil :accessor dsd-print-formatter)
-   (subobject :initarg :subobject :initform nil :accessor dsd-subobject)
-   (reference :initarg :reference :initform nil :accessor dsd-reference)
+  ((ho-type :initarg :ho-type :initform nil)
+   (print-formatter :initarg :print-formatter :initform nil)
+   (subobject :initarg :subobject :initform nil)
+   (reference :initarg :reference :initform nil)
+   (description :initarg :reference :initform nil)
    ))
 
 (defclass hyperobject-esd (standard-effective-slot-definition)
@@ -65,26 +66,28 @@
    (print-formatter :initarg :print-formatter :initform nil :accessor esd-print-formatter)
    (subobject :initarg :subobject :initform nil :accessor esd-subobject)
    (reference :initarg :reference :initform nil :accessor esd-reference)
+   (description :initarg :reference :initform nil :accessor esd-description)
   ))
 
 ;; Main class
 
 (defclass hyperobject-class (standard-class)
-  ((title :initarg :title :type string :initform nil
+  ( ;; slots initialized in defclass
+   (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 :initform nil
-    :documentation "List of fields that contain a list of subobjects objects.")
-   (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) ...)")
-   
+               :documentation "List of slots to print")
+   (description :initarg :description :initform nil
+               :documentation "Class description")
+
    ;;; The remainder of these fields are calculated one time
    ;;; in finalize-inheritence.
+   
+   (subobjects :initform nil :documentation
+              "List of fields that contain a list of subobjects objects.")
+   (references :type list :initform nil :documentation 
+              "List of fields that have references")
+   
    (value-func :initform nil :type function)
    (xmlvalue-func :initform nil :type function)
    (fmtstr-text :initform nil :type string)
@@ -131,24 +134,22 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
   (find-class 'hyperobject-dsd))
 
 
+(defmacro define-class-slot (slot-name &optional required)
+  #+lispworks
+  (defmethod clos:process-a-class-option ((class hyperobject-class)
+                                         (name (eql ,slot-name))
+                                         value)
+    (when (and ,required (null value))
+      (error "hyperobject class slot ~A must have a value" name))
+    (if (null (cdr value))
+       (list name (car value))
+       (list name `',value)))
+  )
 
-#+lispworks
-(defmethod clos:process-a-class-option ((class hyperobject-class)
-                                       (name (eql :title))
-                                       value)
-  (unless value
-    (error "hyperobject-class title must have a value"))
-  (if (null (cdr value))
-      (list name (car value))
-    (list name `',value)))
+(define-class-slot :title)
+(define-class-slot :print-slots)
+(define-class-slot :description)
 
-#+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)
@@ -165,6 +166,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
        :print-formatter (slot-value dsd 'print-formatter)
        :subobject (slot-value dsd 'subobject)
        :reference (slot-value dsd 'reference)
+       :description (slot-value dsd 'description)
        ia)))
   )
 
@@ -190,72 +192,84 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 
 (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 "")
-         (fmtstr-xml "")
-         (fmtstr-text-labels "")
-         (fmtstr-html-labels "")
-         (fmtstr-xml-labels "")
-         (fmtstr-html-ref "")
-         (fmtstr-xml-ref "")
-         (fmtstr-html-ref-labels "")
-         (fmtstr-xml-ref-labels "")
-         (first-field t)
-         (value-func '())
-         (xmlvalue-func '())
-         (classname (class-name cl))
-         (package (symbol-package (class-name cl)))
-         (references nil)
-         (subobjects nil))
-      (declare (ignore classname))
-      (dolist (slot (class-slots cl))
-       (when (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)))
-      (setf (slot-value cl 'subobjects) subobjects)
-      (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))
-         (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))
-                 (print-formatter (slot-value slot 'print-formatter))
-                 (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 :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 ">"))
-             
+
+
+(defun process-subobjects (cl)
+  "Process class subobjects slot"
+  (dolist (slot (class-slots cl))
+    (when (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)))
+  (setf (slot-value cl 'subobjects) subobjects))
+
+(defun process-documentation (cl)
+  "Calculate class documentation slot"
+  (setf (slot-value cl 'documentation)
+       (format nil "Hyperobject class: ~A" (slot-value cl 'description)))
+  )
+
+
+(defun process-views (cl)
+  "Calculate all view slots for a hyperobject class"
+  (let ((fmtstr-text "")
+       (fmtstr-html "")
+       (fmtstr-xml "")
+       (fmtstr-text-labels "")
+       (fmtstr-html-labels "")
+       (fmtstr-xml-labels "")
+       (fmtstr-html-ref "")
+       (fmtstr-xml-ref "")
+       (fmtstr-html-ref-labels "")
+       (fmtstr-xml-ref-labels "")
+       (first-field t)
+       (value-func '())
+       (xmlvalue-func '())
+       (classname (class-name cl))
+       (package (symbol-package (class-name cl)))
+       (references nil)
+       (subobjects nil))
+    (declare (ignore classname))
+    (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))
+       (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))
+             (print-formatter (slot-value slot 'print-formatter))
+             (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 :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)
@@ -288,33 +302,38 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
              (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)
-      
-      (if value-func
-         (setq value-func `(lambda (x) (values ,@value-func)))
+    
+    (setf (slot-value cl 'references) references)
+    
+    (if value-func
+       (setq value-func `(lambda (x) (values ,@value-func)))
        (setq value-func `(lambda () (values))))
-      (setq value-func (compile nil (eval value-func)))
-      
-      (if xmlvalue-func
-         (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
+    (setq value-func (compile nil (eval value-func)))
+    
+    (if xmlvalue-func
+       (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
        (setq xmlvalue-func `(lambda () (values))))
-      (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
-
-      (setf (slot-value cl 'fmtstr-text) fmtstr-text)
-      (setf (slot-value cl 'fmtstr-html) fmtstr-html)
-      (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
-      (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
-      (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
-      (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
-      (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
-      (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
-      (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
-      (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
-      (setf (slot-value cl 'value-func) value-func)
-      (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
-    (values))
+    (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
+    
+    (setf (slot-value cl 'fmtstr-text) fmtstr-text)
+    (setf (slot-value cl 'fmtstr-html) fmtstr-html)
+    (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
+    (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
+    (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
+    (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
+    (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
+    (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
+    (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
+    (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
+    (setf (slot-value cl 'value-func) value-func)
+    (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
+  (values))
 
+(defun init-hyperobject-class (cl)
+  "Initialize a hyperobject class. Calculates all class slots"
+  (process-subobjects cl)
+  (process-documentation cl)
+  (process-views cl))
 
 (defun hyperobject-class-fmtstr-text (obj)
   (slot-value (class-of obj) 'fmtstr-text))