;;;; in Text, HTML, and XML formats. This includes hyperlinking
;;;; capability and sub-objects.
;;;;
-;;;; $Id: hyperobject.lisp,v 1.1 2002/11/03 19:59:10 kevin Exp $
+;;;; $Id: hyperobject.lisp,v 1.2 2002/11/03 20:06:19 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
;; Utilities
-(defun my-class-of (obj)
+(defun kmr-class-of (obj)
#-(or cmu sbcl) (class-of obj)
#+sbcl (sb-pcl:class-of obj)
#+cmu (pcl:class-of obj))
-(defun my-class-name (obj)
+(defun kmr-class-name (obj)
#-(or cmu sbcl) (class-name obj)
#+sbcl (sb-pcl:class-name obj)
#+cmu (pcl:class-name obj))
-(defun xml-cdata (str)
- (concatenate 'string "<![CDATA[" str "]]>"))
+;; Main class
-;;
(defclass ho-class (#-(or cmu sbcl) standard-class
#+cmu pcl::standard-class
#+sbcl sb-pcl::standard-class)
(value-func '())
(xmlvalue-func '())
(classname (class-name cl))
- (package (symbol-package (my-class-name cl)))
+ (package (symbol-package (kmr-class-name cl)))
(ref-fields (slot-value cl 'ref-fields)))
(declare (ignore classname))
(dolist (f (slot-value cl 'fields))
(defun ho-class-fmtstr-text (obj)
- (slot-value (my-class-of obj) 'fmtstr-text))
+ (slot-value (kmr-class-of obj) 'fmtstr-text))
(defun ho-class-fmtstr-html (obj)
- (slot-value (my-class-of obj) 'fmtstr-html))
+ (slot-value (kmr-class-of obj) 'fmtstr-html))
(defun ho-class-fmtstr-xml (obj)
- (slot-value (my-class-of obj) 'fmtstr-xml))
+ (slot-value (kmr-class-of obj) 'fmtstr-xml))
(defun ho-class-fmtstr-text-labels (obj)
- (slot-value (my-class-of obj) 'fmtstr-text-labels))
+ (slot-value (kmr-class-of obj) 'fmtstr-text-labels))
(defun ho-class-fmtstr-html-labels (obj)
- (slot-value (my-class-of obj) 'fmtstr-html-labels))
+ (slot-value (kmr-class-of obj) 'fmtstr-html-labels))
(defun ho-class-fmtstr-xml-labels (obj)
- (slot-value (my-class-of obj) 'fmtstr-xml-labels))
+ (slot-value (kmr-class-of obj) 'fmtstr-xml-labels))
(defun ho-class-value-func (obj)
- (slot-value (my-class-of obj) 'value-func))
+ (slot-value (kmr-class-of obj) 'value-func))
(defun ho-class-xmlvalue-func (obj)
- (slot-value (my-class-of obj) 'xmlvalue-func))
+ (slot-value (kmr-class-of obj) 'xmlvalue-func))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ho-class-title (obj)
- (awhen (slot-value (my-class-of obj) 'title)
+ (awhen (slot-value (kmr-class-of obj) 'title)
(if (consp it)
(car it)
it))))
(defun ho-class-subobjects-lists (obj)
- (slot-value (my-class-of obj) 'subobjects-lists))
+ (slot-value (kmr-class-of obj) 'subobjects-lists))
(defun ho-class-ref-fields (obj)
- (slot-value (my-class-of obj) 'ref-fields))
+ (slot-value (kmr-class-of obj) 'ref-fields))
(defun ho-class-fields (obj)
- (slot-value (my-class-of obj) 'fields))
+ (slot-value (kmr-class-of obj) 'fields))
(defun ho-class-fmtstr-html-ref (obj)
- (slot-value (my-class-of obj) 'fmtstr-html-ref))
+ (slot-value (kmr-class-of obj) 'fmtstr-html-ref))
(defun ho-class-fmtstr-xml-ref (obj)
- (slot-value (my-class-of obj) 'fmtstr-xml-ref))
+ (slot-value (kmr-class-of obj) 'fmtstr-xml-ref))
(defun ho-class-fmtstr-html-ref-labels (obj)
- (slot-value (my-class-of obj) 'fmtstr-html-ref-labels))
+ (slot-value (kmr-class-of obj) 'fmtstr-html-ref-labels))
(defun ho-class-fmtstr-xml-ref-labels (obj)
- (slot-value (my-class-of obj) 'fmtstr-xml-ref-labels))
+ (slot-value (kmr-class-of obj) 'fmtstr-xml-ref-labels))
;;; Class name functions
(string-downcase (subseq name 1)))
(defmethod ho-class-stdname ((cl standard-object))
- (string-downcase (subseq (my-class-name (my-class-of cl)) 1)))
+ (string-downcase (subseq (kmr-class-name (kmr-class-of cl)) 1)))
;;;; Generic Print functions
(defun class-name-of (obj)
- (string-downcase (my-class-name (my-class-of obj))))
+ (string-downcase (kmr-class-name (kmr-class-of obj))))
(defun htmlformat-list-start-value-func (x nitems)
(values (ho-class-title x) nitems (class-name-of x)))