projects
/
hyperobject.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
r3287: *** empty log message ***
[hyperobject.git]
/
hyperobject.lisp
diff --git
a/hyperobject.lisp
b/hyperobject.lisp
index 37f27eb617675bfb6f09730a7effe211218a7211..0e34dcdfc22141da79484a1b529e921d8e2ca18f 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.
;;;;
;;;; 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
;;;;
;;;;
;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
;;;;
@@
-26,20
+26,18
@@
;; Utilities
;; 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))
#-(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))
#-(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)
(defclass ho-class (#-(or cmu sbcl) standard-class
#+cmu pcl::standard-class
#+sbcl sb-pcl::standard-class)
@@
-163,7
+161,7
@@
Format is ((field-name field-lookup-func other-link-params) ...)")
(value-func '())
(xmlvalue-func '())
(classname (class-name cl))
(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))
(ref-fields (slot-value cl 'ref-fields)))
(declare (ignore classname))
(dolist (f (slot-value cl 'fields))
@@
-261,56
+259,56
@@
Format is ((field-name field-lookup-func other-link-params) ...)")
(defun ho-class-fmtstr-text (obj)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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)
(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
;;; Class name functions
@@
-319,7
+317,7
@@
Format is ((field-name field-lookup-func other-link-params) ...)")
(string-downcase (subseq name 1)))
(defmethod ho-class-stdname ((cl standard-object))
(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
;;;; Generic Print functions
@@
-412,7
+410,7
@@
Format is ((field-name field-lookup-func other-link-params) ...)")
(defun class-name-of (obj)
(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)))
(defun htmlformat-list-start-value-func (x nitems)
(values (ho-class-title x) nitems (class-name-of x)))