;;;; 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
;;;;
;; 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))
(: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))
(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))
(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
(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
(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)))
(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))
(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))))))
+