From ec0e06f1c59ea3aa00090010a6d53ea3f712ed1d Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 4 Nov 2002 19:19:04 +0000 Subject: [PATCH] r3292: *** empty log message *** --- debian/changelog | 12 +++++++++ debian/rules | 2 +- hyperobject.lisp | 65 +++++++++++++++++++++++++++++------------------- package.lisp | 5 +++- 4 files changed, 57 insertions(+), 27 deletions(-) diff --git a/debian/changelog b/debian/changelog index b1c3d7d..13681fe 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,15 @@ +cl-hyperobject (1.2.2-1) unstable; urgency=low + + * Change position of a defclass + + -- Kevin M. Rosenberg Mon, 4 Nov 2002 12:09:58 -0700 + +cl-hyperobject (1.2.1-1) unstable; urgency=low + + * Fix parameter bug + + -- Kevin M. Rosenberg Mon, 4 Nov 2002 11:37:35 -0700 + cl-hyperobject (1.2-1) unstable; urgency=low * New upstream diff --git a/debian/rules b/debian/rules index 66e1069..8eeb8e4 100755 --- a/debian/rules +++ b/debian/rules @@ -51,7 +51,7 @@ binary-indep: build install dh_testroot -i # dh_installdebconf dh_installdocs -i -# dh_installexamples -i hyperobject-example.lisp + dh_installexamples -i hyperobject-example.lisp # dh_installmenu # dh_installlogrotate # dh_installemacsen diff --git a/hyperobject.lisp b/hyperobject.lisp index e95b811..926fde9 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.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)))))) + diff --git a/package.lisp b/package.lisp index da354bb..93383b6 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.3 2002/11/04 18:02:13 kevin Exp $ +;;;; $Id: package.lisp,v 1.4 2002/11/04 19:19:04 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -20,6 +20,7 @@ (:nicknames #:ho) (:use #:common-lisp #:kmrcl) (:export + #:hyperobject #:hyperobject-class #:hyperobject-base-url! #:hyperobject-class-title @@ -27,4 +28,6 @@ #:print-hyperobject )) +(defpackage #:hyperobject-user + (:use #:hyperobject #:cl #:cl-user)) -- 2.34.1