From c257d1813b0eb826e8473ea267b60a16cf5d531c Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 4 Nov 2002 18:02:40 +0000 Subject: [PATCH] r3291: *** empty log message *** --- debian/changelog | 12 ++++ debian/control | 2 +- hyperobject.lisp | 154 ++++++++++++++++++++++++----------------------- package.lisp | 10 +-- 4 files changed, 97 insertions(+), 81 deletions(-) diff --git a/debian/changelog b/debian/changelog index ab46d98..b1c3d7d 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,15 @@ +cl-hyperobject (1.2-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Mon, 4 Nov 2002 09:38:26 -0700 + +cl-hyperobject (1.1-1) unstable; urgency=low + + * Fix upstream + + -- Kevin M. Rosenberg Sun, 3 Nov 2002 16:34:52 -0700 + cl-hyperobject (1.0-1) unstable; urgency=low * Initial Release (closes: 167591) diff --git a/debian/control b/debian/control index e22b2f4..5fc7d3b 100644 --- a/debian/control +++ b/debian/control @@ -8,7 +8,7 @@ Standards-Version: 3.5.7.1 Package: cl-hyperobject Architecture: all Depends: ${shlibs:Depends}, common-lisp-controller, cl-kmrcl -Description: Common Lisp library for hyperobject +Description: Common Lisp library for hyperobjects This package contains a library for creating and display hyperobjects. Hyperobjects contain references to subobjects as well as to linked objects. This package includes functions to display hyperobjects in diff --git a/hyperobject.lisp b/hyperobject.lisp index 0e34dcd..e95b811 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.3 2002/11/04 18:02:13 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -38,7 +38,7 @@ ;; 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 @@ -77,76 +77,76 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (: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 "") @@ -258,65 +258,65 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (values)) -(defun ho-class-fmtstr-text (obj) +(defun hyperobject-class-fmtstr-text (obj) (slot-value (kmr-class-of obj) 'fmtstr-text)) -(defun ho-class-fmtstr-html (obj) +(defun hyperobject-class-fmtstr-html (obj) (slot-value (kmr-class-of obj) 'fmtstr-html)) -(defun ho-class-fmtstr-xml (obj) +(defun hyperobject-class-fmtstr-xml (obj) (slot-value (kmr-class-of obj) 'fmtstr-xml)) -(defun ho-class-fmtstr-text-labels (obj) +(defun hyperobject-class-fmtstr-text-labels (obj) (slot-value (kmr-class-of obj) 'fmtstr-text-labels)) -(defun ho-class-fmtstr-html-labels (obj) +(defun hyperobject-class-fmtstr-html-labels (obj) (slot-value (kmr-class-of obj) 'fmtstr-html-labels)) -(defun ho-class-fmtstr-xml-labels (obj) +(defun hyperobject-class-fmtstr-xml-labels (obj) (slot-value (kmr-class-of obj) 'fmtstr-xml-labels)) -(defun ho-class-value-func (obj) +(defun hyperobject-class-value-func (obj) (slot-value (kmr-class-of obj) 'value-func)) -(defun ho-class-xmlvalue-func (obj) +(defun hyperobject-class-xmlvalue-func (obj) (slot-value (kmr-class-of obj) 'xmlvalue-func)) (eval-when (:compile-toplevel :load-toplevel :execute) -(defun ho-class-title (obj) +(defun hyperobject-class-title (obj) (awhen (slot-value (kmr-class-of obj) 'title) (if (consp it) (car it) it)))) -(defun ho-class-subobjects-lists (obj) +(defun hyperobject-class-subobjects-lists (obj) (slot-value (kmr-class-of obj) 'subobjects-lists)) -(defun ho-class-ref-fields (obj) +(defun hyperobject-class-ref-fields (obj) (slot-value (kmr-class-of obj) 'ref-fields)) -(defun ho-class-fields (obj) +(defun hyperobject-class-fields (obj) (slot-value (kmr-class-of obj) 'fields)) -(defun ho-class-fmtstr-html-ref (obj) +(defun hyperobject-class-fmtstr-html-ref (obj) (slot-value (kmr-class-of obj) 'fmtstr-html-ref)) -(defun ho-class-fmtstr-xml-ref (obj) +(defun hyperobject-class-fmtstr-xml-ref (obj) (slot-value (kmr-class-of obj) 'fmtstr-xml-ref)) -(defun ho-class-fmtstr-html-ref-labels (obj) +(defun hyperobject-class-fmtstr-html-ref-labels (obj) (slot-value (kmr-class-of obj) 'fmtstr-html-ref-labels)) -(defun ho-class-fmtstr-xml-ref-labels (obj) +(defun hyperobject-class-fmtstr-xml-ref-labels (obj) (slot-value (kmr-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)) +(defmethod hyperobject-class-stdname ((cl standard-object)) (string-downcase (subseq (kmr-class-name (kmr-class-of cl)) 1))) ;;;; Generic Print functions @@ -357,7 +357,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 +395,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 +403,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)))) (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 +432,9 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-end-fmtstr "~%" :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 +453,16 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-end-fmtstr "~%" :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 +480,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 +499,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 "&")) (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 "&") @@ -654,10 +654,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 +697,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,10 +723,10 @@ 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 + (print-hyperobject-class it fmt strm label english-only-function (1+ indent) subobjects refvars))))) (fmt-obj-end obj fmt strm indent))) @@ -734,15 +734,17 @@ Format is ((field-name field-lookup-func other-link-params) ...)") 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 english-only-function 0 subobjects refvars)) (if file-wrapper (fmt-file-end fmt os))) objs) + diff --git a/package.lisp b/package.lisp index 0c23053..da354bb 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.2 2002/11/03 20:06:19 kevin Exp $ +;;;; $Id: package.lisp,v 1.3 2002/11/04 18:02:13 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -17,12 +17,14 @@ (in-package :cl-user) (defpackage #:hyperobject + (:nicknames #:ho) (:use #:common-lisp #:kmrcl) (:export - #:ml-class - #:ml-class-title + #:hyperobject-class + #:hyperobject-base-url! + #:hyperobject-class-title #:load-all-subobjects - #:print-ho + #:print-hyperobject )) -- 2.34.1