r3292: *** empty log message ***

[hyperobject.git] / hyperobject.lisp

diff --git a/hyperobject.lisp b/hyperobject.lisp
index e95b8118ed2ac2197c5b2cacd586af85fa3e09cb..926fde9b7d17847a96f057a9ad0c3a74818ca156 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.3 2002/11/04 18:02:13 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,12 +26,12 @@
 
 ;; 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))
@@ -76,6 +76,7 @@ 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 hyperobject-class))
   (init-hyperobject-class cl))
@@ -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))
@@ -259,56 +260,56 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 
 
 (defun hyperobject-class-fmtstr-text (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-text))
+  (slot-value (portable-class-of obj) 'fmtstr-text))
 
 (defun hyperobject-class-fmtstr-html (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html))
+  (slot-value (portable-class-of obj) 'fmtstr-html))
 
 (defun hyperobject-class-fmtstr-xml (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml))
+  (slot-value (portable-class-of obj) 'fmtstr-xml))
 
 (defun hyperobject-class-fmtstr-text-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-text-labels))
+  (slot-value (portable-class-of obj) 'fmtstr-text-labels))
 
 (defun hyperobject-class-fmtstr-html-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html-labels))
+  (slot-value (portable-class-of obj) 'fmtstr-html-labels))
 
 (defun hyperobject-class-fmtstr-xml-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml-labels))
+  (slot-value (portable-class-of obj) 'fmtstr-xml-labels))
 
 (defun hyperobject-class-value-func (obj)
-  (slot-value (kmr-class-of obj) 'value-func))
+  (slot-value (portable-class-of obj) 'value-func))
 
 (defun hyperobject-class-xmlvalue-func (obj)
-  (slot-value (kmr-class-of obj) 'xmlvalue-func))
+  (slot-value (portable-class-of obj) 'xmlvalue-func))
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
 (defun hyperobject-class-title (obj)
-  (awhen (slot-value (kmr-class-of obj) 'title)
+  (awhen (slot-value (portable-class-of obj) 'title)
            (if (consp it)
                (car it)
              it))))
 
 (defun hyperobject-class-subobjects-lists (obj)
-  (slot-value (kmr-class-of obj) 'subobjects-lists))
+  (slot-value (portable-class-of obj) 'subobjects-lists))
 
 (defun hyperobject-class-ref-fields (obj)
-  (slot-value (kmr-class-of obj) 'ref-fields))
+  (slot-value (portable-class-of obj) 'ref-fields))
 
 (defun hyperobject-class-fields (obj)
-  (slot-value (kmr-class-of obj) 'fields))
+  (slot-value (portable-class-of obj) 'fields))
 
 (defun hyperobject-class-fmtstr-html-ref (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html-ref))
+  (slot-value (portable-class-of obj) 'fmtstr-html-ref))
 
 (defun hyperobject-class-fmtstr-xml-ref (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml-ref))
+  (slot-value (portable-class-of obj) 'fmtstr-xml-ref))
 
 (defun hyperobject-class-fmtstr-html-ref-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-html-ref-labels))
+  (slot-value (portable-class-of obj) 'fmtstr-html-ref-labels))
 
 (defun hyperobject-class-fmtstr-xml-ref-labels (obj)
-  (slot-value (kmr-class-of obj) 'fmtstr-xml-ref-labels))
+  (slot-value (portable-class-of obj) 'fmtstr-xml-ref-labels))
 
 ;;; Class name functions
 
@@ -317,7 +318,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
   (string-downcase (subseq name 1)))
   
 (defmethod hyperobject-class-stdname ((cl standard-object))
-  (string-downcase (subseq (kmr-class-name (kmr-class-of cl)) 1)))
+  (string-downcase (subseq (portable-class-name (portable-class-of cl)) 1)))
   
 ;;;; Generic Print functions
 
@@ -410,7 +411,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
 
 
 (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 (hyperobject-class-title x) nitems (class-name-of x)))
@@ -727,8 +728,8 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
                         (dolist (child-obj it)   ;; for each child function
                           (awhen (funcall (car child-obj) obj) ;; access set of child objects
                                     (print-hyperobject-class it fmt strm label 
-                                                     english-only-function
-                                                     (1+ indent) subobjects refvars)))))
+                                                     (1+ indent) english-only-function
+                                                    subobjects refvars)))))
           (fmt-obj-end obj fmt strm indent)))
       (fmt-list-end (car objs) fmt strm indent nobjs))
     t))
@@ -743,8 +744,22 @@ Format is ((field-name field-lookup-func other-link-params) ...)")
     (if file-wrapper
        (fmt-file-start fmt os))
     (when objs
-      (print-hyperobject-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))))))
+