X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=hyperobject.lisp;h=926fde9b7d17847a96f057a9ad0c3a74818ca156;hb=2b7f11038d88180777d7c6ac9a02f26c020c2c0d;hp=0e34dcdfc22141da79484a1b529e921d8e2ca18f;hpb=eeecdad997c633f810028c741e9562554e6f105d;p=hyperobject.git

diff --git a/hyperobject.lisp b/hyperobject.lisp
index 0e34dcd..926fde9 100644
--- 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.2 2002/11/03 20:06:19 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.4 2002/11/04 19:19:04 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -26,19 +26,19 @@
 
 ;; Utilities
 
-(defun kmr-class-of (obj)
+(defun portable-class-of (obj)
   #-(or cmu sbcl) (class-of obj)
   #+sbcl (sb-pcl:class-of obj)
   #+cmu (pcl:class-of obj))
 
-(defun kmr-class-name (obj)
+(defun portable-class-name (obj)
   #-(or cmu sbcl) (class-name obj)
   #+sbcl (sb-pcl:class-name obj)
   #+cmu (pcl:class-name obj))
 
 ;; Main class
 
-(defclass ho-class (#-(or cmu sbcl) standard-class
+(defclass hyperobject-class (#-(or cmu sbcl) standard-class
 		      #+cmu pcl::standard-class
 		      #+sbcl sb-pcl::standard-class)
   ((title :initarg :title :type string :reader ml-std-title
@@ -76,77 +76,78 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
   (:default-initargs :title nil :fields nil :subobjects-lists nil :ref-fields nil)
   (:documentation "Metaclass for Markup Language classes."))
 
+
 #+cmu
-(defmethod pcl:finalize-inheritance :after ((cl ho-class))
-  (init-ho-class cl))
+(defmethod pcl:finalize-inheritance :after ((cl hyperobject-class))
+  (init-hyperobject-class cl))
 
 #+scl
-(defmethod clos:finalize-inheritance :after ((cl ho-class))
-  (init-ho-class cl))
+(defmethod clos:finalize-inheritance :after ((cl hyperobject-class))
+  (init-hyperobject-class cl))
 
 
 #+sbcl
-(defmethod sb-pcl:finalize-inheritance :after ((cl ho-class))
-  (init-ho-class cl))
+(defmethod sb-pcl:finalize-inheritance :after ((cl hyperobject-class))
+  (init-hyperobject-class cl))
 
 
 #+cmu
-(defmethod pcl:validate-superclass ((class ho-class) (superclass pcl::standard-class))
+(defmethod pcl:validate-superclass ((class hyperobject-class) (superclass pcl::standard-class))
   t)
 
 #+scl
-(defmethod clos:validate-superclass ((class ho-class) (superclass standard-class))
+(defmethod clos:validate-superclass ((class hyperobject-class) (superclass standard-class))
   t)
 
 #+sbcl
-(defmethod sb-pcl:validate-superclass ((class ho-class) (superclass sb-pcl::standard-class))
+(defmethod sb-pcl:validate-superclass ((class hyperobject-class) (superclass sb-pcl::standard-class))
   t)
 
 #+allegro
-(defmethod mop:finalize-inheritance :after ((cl ho-class))
-  (init-ho-class cl))
+(defmethod mop:finalize-inheritance :after ((cl hyperobject-class))
+  (init-hyperobject-class cl))
 
 #+lispworks
-(defmethod clos:finalize-inheritance :after ((cl ho-class))
-  (init-ho-class cl))
+(defmethod clos:finalize-inheritance :after ((cl hyperobject-class))
+  (init-hyperobject-class cl))
 
 #+lispworks
-(defmethod clos:process-a-class-option ((class ho-class)
+(defmethod clos:process-a-class-option ((class hyperobject-class)
 					(name (eql :title))
 					value)
   (unless value
-    (error "ho-class title must have a value"))
+    (error "hyperobject-class title must have a value"))
   (if (null (cdr value))
       (list name (car value))
     (list name `',value)))
 
 #+lispworks
-(defmethod clos:process-a-class-option ((class ho-class)
+(defmethod clos:process-a-class-option ((class hyperobject-class)
 					(name (eql :fields))
 					value)
   (unless value
-    (error "ho-class fields must have a value"))
+    (error "hyperobject-class fields must have a value"))
   (list name `',value))
 
 #+lispworks
-(defmethod clos:process-a-class-option ((class ho-class)
+(defmethod clos:process-a-class-option ((class hyperobject-class)
 					(name (eql :ref-fields))
 					value)
   (unless value
-    (error "ho-class ref-fields must have a value"))
+    (error "hyperobject-class ref-fields must have a value"))
   (list name `',value))
 
 #+lispworks
-(defmethod clos:process-a-class-option ((class ho-class)
+(defmethod clos:process-a-class-option ((class hyperobject-class)
 					(name (eql :subobjects-lists))
 					value)
   (unless value
-    (error "ho-class subobjects-lists must have a value"))
+    (error "hyperobject-class subobjects-lists must have a value"))
   (list name `',value))
 
 ;;;; Class initialization function
       
-(defun init-ho-class (cl)
+(defun init-hyperobject-class (cl)
     (let ((fmtstr-text "")
 	  (fmtstr-html "")
 	  (fmtstr-xml "")
@@ -161,7 +162,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 	  (value-func '())
 	  (xmlvalue-func '())
 	  (classname (class-name cl))
-	  (package (symbol-package (kmr-class-name cl)))
+	  (package (symbol-package (portable-class-name cl)))
 	  (ref-fields (slot-value cl 'ref-fields)))
       (declare (ignore classname))
       (dolist (f (slot-value cl 'fields))
@@ -258,66 +259,66 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
     (values))
 
 
-(defun ho-class-fmtstr-text (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-text))
+(defun hyperobject-class-fmtstr-text (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-text))
 
-(defun ho-class-fmtstr-html (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html))
+(defun hyperobject-class-fmtstr-html (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-html))
 
-(defun ho-class-fmtstr-xml (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml))
+(defun hyperobject-class-fmtstr-xml (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-xml))
 
-(defun ho-class-fmtstr-text-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-text-labels))
+(defun hyperobject-class-fmtstr-text-labels (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-text-labels))
 
-(defun ho-class-fmtstr-html-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html-labels))
+(defun hyperobject-class-fmtstr-html-labels (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-html-labels))
 
-(defun ho-class-fmtstr-xml-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml-labels))
+(defun hyperobject-class-fmtstr-xml-labels (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-xml-labels))
 
-(defun ho-class-value-func (obj)
-  (slot-value (kmr-class-of obj) 'value-func))
+(defun hyperobject-class-value-func (obj)
+  (slot-value (portable-class-of obj) 'value-func))
 
-(defun ho-class-xmlvalue-func (obj)
-  (slot-value (kmr-class-of obj) 'xmlvalue-func))
+(defun hyperobject-class-xmlvalue-func (obj)
+  (slot-value (portable-class-of obj) 'xmlvalue-func))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-(defun ho-class-title (obj)
-  (awhen (slot-value (kmr-class-of obj) 'title)
+(defun hyperobject-class-title (obj)
+  (awhen (slot-value (portable-class-of obj) 'title)
 	    (if (consp it)
 		(car it)
 	      it))))
 
-(defun ho-class-subobjects-lists (obj)
-  (slot-value (kmr-class-of obj) 'subobjects-lists))
+(defun hyperobject-class-subobjects-lists (obj)
+  (slot-value (portable-class-of obj) 'subobjects-lists))
 
-(defun ho-class-ref-fields (obj)
-  (slot-value (kmr-class-of obj) 'ref-fields))
+(defun hyperobject-class-ref-fields (obj)
+  (slot-value (portable-class-of obj) 'ref-fields))
 
-(defun ho-class-fields (obj)
-  (slot-value (kmr-class-of obj) 'fields))
+(defun hyperobject-class-fields (obj)
+  (slot-value (portable-class-of obj) 'fields))
 
-(defun ho-class-fmtstr-html-ref (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html-ref))
+(defun hyperobject-class-fmtstr-html-ref (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-html-ref))
 
-(defun ho-class-fmtstr-xml-ref (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml-ref))
+(defun hyperobject-class-fmtstr-xml-ref (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-xml-ref))
 
-(defun ho-class-fmtstr-html-ref-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html-ref-labels))
+(defun hyperobject-class-fmtstr-html-ref-labels (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-html-ref-labels))
 
-(defun ho-class-fmtstr-xml-ref-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml-ref-labels))
+(defun hyperobject-class-fmtstr-xml-ref-labels (obj)
+  (slot-value (portable-class-of obj) 'fmtstr-xml-ref-labels))
 
 ;;; Class name functions
 
-(defgeneric ho-class-stdname (x))
-(defmethod ho-class-stdname ((name string))
+(defgeneric hyperobject-class-stdname (x))
+(defmethod hyperobject-class-stdname ((name string))
   (string-downcase (subseq name 1)))
   
-(defmethod ho-class-stdname ((cl standard-object))
-  (string-downcase (subseq (kmr-class-name (kmr-class-of cl)) 1)))
+(defmethod hyperobject-class-stdname ((cl standard-object))
+  (string-downcase (subseq (portable-class-name (portable-class-of cl)) 1)))
   
 ;;;; Generic Print functions
 
@@ -357,7 +358,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
       (:null *default-nullformat*)
       (otherwise *default-textformat*)))
     
-;;;; Output format classes for print ho-classes
+;;;; Output format classes for print hyperobject-classes
 
 (defclass dataformat ()
   ((file-start-str :type string :initarg :file-start-str :reader file-start-str)
@@ -395,7 +396,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
   ())
 
 (defun text-list-start-value-func (obj nitems)
-  (values (ho-class-title obj) nitems))
+  (values (hyperobject-class-title obj) nitems))
 
 (defclass textformat (dataformat) 
   ()	
@@ -403,17 +404,17 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
     :list-start-value-func #'text-list-start-value-func
     :list-start-indent t
     :obj-data-indent t
-    :obj-data-fmtstr #'ho-class-fmtstr-text
-    :obj-data-fmtstr-labels #'ho-class-fmtstr-text-labels
+    :obj-data-fmtstr #'hyperobject-class-fmtstr-text
+    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels
     :obj-data-end-fmtstr "~%"
-    :obj-data-value-func #'ho-class-value-func))
+    :obj-data-value-func #'hyperobject-class-value-func))
 
 
 (defun class-name-of (obj)
-  (string-downcase (kmr-class-name (kmr-class-of obj))))
+  (string-downcase (portable-class-name (portable-class-of obj))))
 
 (defun htmlformat-list-start-value-func (x nitems) 
-  (values (ho-class-title x) nitems (class-name-of x)))
+  (values (hyperobject-class-title x) nitems (class-name-of x)))
 
 (defclass htmlformat (textformat) 
   ()
@@ -432,9 +433,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
     :obj-end-fmtstr  "</li>~%"
     :obj-end-value-func #'identity
     :obj-data-indent t
-    :obj-data-fmtstr #'ho-class-fmtstr-html-labels
-    :obj-data-fmtstr-labels #'ho-class-fmtstr-html-labels
-    :obj-data-value-func #'ho-class-value-func))
+    :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
+    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
+    :obj-data-value-func #'hyperobject-class-value-func))
 
 (defclass xhtmlformat (textformat) 
   ()
@@ -453,16 +454,16 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
     :obj-end-fmtstr  "</li>~%"
     :obj-end-value-func #'identity
     :obj-data-indent t
-    :obj-data-fmtstr #'ho-class-fmtstr-html-labels
-    :obj-data-fmtstr-labels #'ho-class-fmtstr-html-labels
-    :obj-data-value-func #'ho-class-xmlvalue-func))
+    :obj-data-fmtstr #'hyperobject-class-fmtstr-html-labels
+    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-html-labels
+    :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 
 
 (defun xmlformat-list-end-value-func (x)
   (format nil "~alist" (class-name-of x)))
 
 (defun xmlformat-list-start-value-func (x nitems) 
-  (values (format nil "~alist" (class-name-of x)) (ho-class-title x) nitems))
+  (values (format nil "~alist" (class-name-of x)) (hyperobject-class-title x) nitems))
 
 (defclass xmlformat (textformat) 
   ()
@@ -480,9 +481,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
     :obj-end-value-func #'class-name-of
     :obj-end-indent nil
     :obj-data-indent nil
-    :obj-data-fmtstr #'ho-class-fmtstr-xml
-    :obj-data-fmtstr-labels #'ho-class-fmtstr-xml-labels
-    :obj-data-value-func #'ho-class-xmlvalue-func))
+    :obj-data-fmtstr #'hyperobject-class-fmtstr-xml
+    :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-xml-labels
+    :obj-data-value-func #'hyperobject-class-xmlvalue-func))
 
 (defclass link-ref ()
   ((fmtstr :type function :initarg :fmtstr :accessor fmtstr)
@@ -499,24 +500,24 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 
 (defclass html-link-ref (link-ref)
   ()
-  (:default-initargs :fmtstr #'ho-class-fmtstr-html-ref  
-    :fmtstr-labels #'ho-class-fmtstr-html-ref-labels
+  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref  
+    :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
     :href-head "a href=" 
     :href-end "a" 
     :ampersand "&"))
 
 (defclass xhtml-link-ref (link-ref)
   ()
-  (:default-initargs :fmtstr #'ho-class-fmtstr-html-ref  
-    :fmtstr-labels #'ho-class-fmtstr-html-ref-labels
+  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-html-ref  
+    :fmtstr-labels #'hyperobject-class-fmtstr-html-ref-labels
     :href-head "a href=" 
     :href-end "a" 
     :ampersand "&amp;"))
 
 (defclass xml-link-ref (link-ref)
   ()
-  (:default-initargs :fmtstr #'ho-class-fmtstr-xml-ref 
-		     :fmtstr-labels #'ho-class-fmtstr-xml-ref-labels
+  (:default-initargs :fmtstr #'hyperobject-class-fmtstr-xml-ref 
+		     :fmtstr-labels #'hyperobject-class-fmtstr-xml-ref-labels
 		     :href-head "xmllink xlink:type=\"simple\" xlink:href=" 
 		     :href-end "xmllink" 
 		     :ampersand "&amp;")
@@ -654,10 +655,10 @@ 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 (ho-class-ref-fields x))
+    (dolist (field (hyperobject-class-ref-fields x))
       (let ((link-start 
 	     (make-link-start x (link-ref fmt) (car field) (cadr field)
-			      (nth (position (car field) (ho-class-fields x) :key #'car) field-values)  
+			      (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))))
 	(push link-start refvalues)
@@ -697,21 +698,21 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
   (when objs
     (let ((objlist (mklist objs)))
       (dolist (obj objlist)
-        (awhen (ho-class-subobjects-lists obj)  ;; access list of functions
+        (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
           (dolist (child-obj it)   ;; for each child function
             (awhen (funcall (car child-obj) obj)
               (load-all-subobjects it))))))
     objs))
 
-(defgeneric output-ho-class (objs fmt strm
+(defgeneric print-hyperobject-class (objs fmt strm
 				  &optional label english-only-function
 				  indent subobjects refvars))
 
-(defmethod output-ho-class (objs (fmt dataformat) (strm stream) 
+(defmethod print-hyperobject-class (objs (fmt dataformat) (strm stream) 
 				 &optional (label nil) (indent 0)
 				 (english-only-function nil)
 				 (subobjects nil) (refvars nil))
-  "Display a single or list of ho-class instances and their subobjects"
+"Display a single or list of hyperobject-class instances and their subobjects"
   (when objs
     (setq objs (mklist objs))
     (let ((nobjs (length objs)))
@@ -723,26 +724,42 @@ 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 (ho-class-subobjects-lists obj)  ;; access list of functions
+              (awhen (hyperobject-class-subobjects-lists obj)  ;; access list of functions
                         (dolist (child-obj it)   ;; for each child function
                           (awhen (funcall (car child-obj) obj) ;; access set of child objects
-                                    (output-ho-class it fmt strm label 
-                                                     english-only-function
-                                                     (1+ indent) subobjects refvars)))))
+                                    (print-hyperobject-class it fmt strm label 
+                                                     (1+ indent) english-only-function
+						     subobjects refvars)))))
           (fmt-obj-end obj fmt strm indent)))
       (fmt-list-end (car objs) fmt strm indent nobjs))
     t))
 
 
-(defun print-ho (objs &key (os *standard-output*) (format :text)
+
+(defun print-hyperobject (objs &key (os *standard-output*) (format :text)
 		      (label nil) (english-only-function nil)
 		      (subobjects nil) (file-wrapper t) (refvars nil))
-  "EXPORTED Function: prints ho-class objects. Simplies call to output-ho-class"
+  "EXPORTED Function: prints hyperobject-class objects. Simplies call to print-hyperobject-class"
   (let ((fmt (make-format-instance format)))
     (if file-wrapper
 	(fmt-file-start fmt os))
     (when objs
-      (output-ho-class objs fmt os label english-only-function 0 subobjects refvars))
+      (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars))
     (if file-wrapper
 	(fmt-file-end fmt os)))
   objs)
+
+
+(defclass hyperobject ()
+  ()
+  (:metaclass hyperobject-class))
+
+
+(defmethod print-object ((obj hyperobject) (s stream))
+  (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)
+	     (multiple-value-list 
+	      (funcall (funcall (hyperobject::obj-data-value-func fmt) obj) obj))))))
+