From a332fc23291a68f46d2e973df7c28ec07a4abcfe Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 25 Nov 2002 04:49:22 +0000 Subject: [PATCH] r3473: *** empty log message *** --- hyperobject.lisp | 487 +++-------------------------------------------- 1 file changed, 25 insertions(+), 462 deletions(-) diff --git a/hyperobject.lisp b/hyperobject.lisp index 60d3483..f6ad52c 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.14 2002/11/25 04:47:23 kevin Exp $ +;;;; $Id: hyperobject.lisp,v 1.15 2002/11/25 04:49:22 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -52,25 +52,6 @@ :hyperobject)) -;; Slot definitions - - -(defclass hyperobject-dsd (standard-direct-slot-definition) - ((ho-type :initarg :ho-type :initform nil) - (print-formatter :initarg :print-formatter :initform nil) - (subobject :initarg :subobject :initform nil) - (reference :initarg :reference :initform nil) - (description :initarg :description :initform nil) - )) - -(defclass hyperobject-esd (standard-effective-slot-definition) - ((ho-type :initarg :ho-type :initform nil :accessor esd-ho-type) - (print-formatter :initarg :print-formatter :initform nil :accessor esd-print-formatter) - (subobject :initarg :subobject :initform nil :accessor esd-subobject) - (reference :initarg :reference :initform nil :accessor esd-reference) - (description :initarg :description :initform nil :accessor esd-description) - )) - ;; Main class (defclass hyperobject-class (standard-class) @@ -141,11 +122,11 @@ `(defmethod clos:process-a-class-option ((class hyperobject-class) (name (eql ,slot-name)) value) - (when (and ,required (null value)) - (error "hyperobject class slot ~A must have a value" name)) - (if (null (cdr value)) - (list name (car value)) - (list name `',value))) + (when (and ,required (null value)) + (error "hyperobject class slot ~A must have a value" name)) + (if (null (cdr value)) + `(name ,(car value)) + `(name (quote value)))) #+(or allegro sbcl cmu scl) (declare (ignore slot-name required)) ) @@ -157,9 +138,7 @@ value already-processed-other-options slot) - (if (null (cdr value)) - (list option (car value)) - (list option `',value))) + (list option value)) #-lispworks (declare (ignore slot-name)) ) @@ -168,12 +147,29 @@ (define-class-option :print-slots) (define-class-option :description) -(define-slot-option :ho-type) (define-slot-option :print-formatter) (define-slot-option :subobject) (define-slot-option :reference) (define-slot-option :description) +;; Slot definitions + +(defclass hyperobject-dsd (standard-direct-slot-definition) + ((ho-type :initarg :ho-type) + (print-formatter :initarg :print-formatter) + (subobject :initarg :subobject :initarg nil) + (reference :initarg :reference :initarg nil) + (description :initarg :description :initarg nil) + )) + +(defclass hyperobject-esd (standard-effective-slot-definition) + ((ho-type :initarg :ho-type :accessor esd-ho-type) + (print-formatter :initarg :print-formatter :accessor esd-print-formatter) + (subobject :initarg :subobject :accessor esd-subobject) + (reference :initarg :reference :accessor esd-reference) + (description :initarg :description :accessor esd-description) + )) + (defmethod compute-effective-slot-definition :around @@ -426,436 +422,3 @@ (defun hyperobject-class-fmtstr-xml-ref-labels (obj) (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) -;;;; Generic Print functions - -(defparameter *default-textformat* nil) -(defparameter *default-htmlformat* nil) -(defparameter *default-htmlrefformat* nil) -(defparameter *default-xhtmlformat* nil) -(defparameter *default-xhtmlrefformat* nil) -(defparameter *default-xmlformat* nil) -(defparameter *default-xmlrefformat* nil) -(defparameter *default-ie-xmlrefformat* nil) -(defparameter *default-nullformat* nil) -(defparameter *default-init-format?* nil) - -(defun make-format-instance (fmt) - (unless *default-init-format?* - (setq *default-textformat* (make-instance 'textformat)) - (setq *default-htmlformat* (make-instance 'htmlformat)) - (setq *default-htmlrefformat* (make-instance 'htmlrefformat)) - (setq *default-xhtmlformat* (make-instance 'xhtmlformat)) - (setq *default-xhtmlrefformat* (make-instance 'xhtmlrefformat)) - (setq *default-xmlformat* (make-instance 'xmlformat)) - (setq *default-xmlrefformat* (make-instance 'xmlrefformat)) - (setq *default-ie-xmlrefformat* (make-instance 'ie-xmlrefformat)) - (setq *default-nullformat* (make-instance 'nullformat)) - (setq *default-init-format?* t)) - - (case fmt - (:text *default-textformat*) - (:html *default-htmlformat*) - (:htmlref *default-htmlrefformat*) - (:xhtml *default-xhtmlformat*) - (:xhtmlref *default-xhtmlrefformat*) - (:xml *default-xmlformat*) - (:xmlref *default-xmlrefformat*) - (:ie-xmlref *default-ie-xmlrefformat*) - (:null *default-nullformat*) - (otherwise *default-textformat*))) - -;;;; Output format classes for print hyperobject-classes - -(defclass dataformat () - ((file-start-str :type string :initarg :file-start-str :reader file-start-str) - (file-end-str :type string :initarg :file-end-str :reader file-end-str) - (list-start-fmtstr :type string :initarg :list-start-fmtstr :reader list-start-fmtstr) - (list-start-value-func :type function :initarg :list-start-value-func :reader list-start-value-func) - (list-start-indent :initarg :list-start-indent :reader list-start-indent) - (list-end-fmtstr :type string :initarg :list-end-fmtstr :reader list-end-fmtstr) - (list-end-value-func :type function :initarg :list-end-value-func :reader list-end-value-func) - (list-end-indent :initarg :list-end-indent :reader list-end-indent) - (obj-start-fmtstr :type string :initarg :obj-start-fmtstr :reader obj-start-fmtstr) - (obj-start-value-func :initarg :obj-start-value-func :reader obj-start-value-func) - (obj-start-indent :initarg :obj-start-indent :reader obj-start-indent) - (obj-end-fmtstr :type string :initarg :obj-end-fmtstr :reader obj-end-fmtstr) - (obj-end-value-func :initarg :obj-end-value-func :reader obj-end-value-func) - (obj-end-indent :initarg :obj-end-indent :reader obj-end-indent) - (obj-data-indent :initarg :obj-data-indent :reader obj-data-indent) - (obj-data-fmtstr :initarg :obj-data-fmtstr :reader obj-data-fmtstr) - (obj-data-fmtstr-labels :initarg :obj-data-fmtstr-labels :reader obj-data-fmtstr-labels) - (obj-data-end-fmtstr :initarg :obj-data-end-fmtstr :reader obj-data-end-fmtstr) - (obj-data-value-func :initarg :obj-data-value-func :reader obj-data-value-func) - (link-ref :initarg :link-ref :reader link-ref)) - (:default-initargs :file-start-str nil :file-end-str nil :list-start-fmtstr nil :list-start-value-func nil - :list-start-indent nil :list-end-fmtstr nil :list-end-value-func nil :list-end-indent nil - :obj-start-fmtstr nil :obj-start-value-func nil :obj-start-indent nil - :obj-end-fmtstr nil :obj-end-value-func nil :obj-end-indent nil - :obj-data-indent nil :obj-data-fmtstr nil :obj-data-fmtstr-labels nil :obj-data-end-fmtstr nil - :obj-data-value-func nil :link-ref nil) - (:documentation "Parent for all dataformat objects")) - -(defclass binaryformat (dataformat) - ()) - -(defclass nullformat (dataformat) - ()) - -(defun text-list-start-value-func (obj nitems) - (values (hyperobject-class-title obj) nitems)) - -(defclass textformat (dataformat) - () - (:default-initargs :list-start-fmtstr "~a~P:~%" - :list-start-value-func #'text-list-start-value-func - :list-start-indent t - :obj-data-indent t - :obj-data-fmtstr #'hyperobject-class-fmtstr-text - :obj-data-fmtstr-labels #'hyperobject-class-fmtstr-text-labels - :obj-data-end-fmtstr "~%" - :obj-data-value-func #'hyperobject-class-value-func)) - - -(defun class-name-of (obj) - (string-downcase (class-name (class-of obj)))) - -(defun htmlformat-list-start-value-func (x nitems) - (values (hyperobject-class-title x) nitems (class-name-of x))) - -(defclass htmlformat (textformat) - () - (:default-initargs :file-start-str "~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "

~a~p:

~%" - :list-end-indent t - :list-end-value-func #'identity - :obj-start-indent t - :obj-start-fmtstr "
  • " - :obj-start-value-func #'identity - :obj-end-indent t - :obj-end-fmtstr "
    • ~%" - :obj-end-value-func #'identity - :obj-data-indent t - :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) - () - (:default-initargs :file-start-str "~%" - :file-end-str "~%" - :list-start-indent t - :list-start-fmtstr "

    ~a~p:

    ~%" - :list-end-indent t - :list-end-value-func #'identity - :obj-start-indent t - :obj-start-fmtstr "
  • " - :obj-start-value-func #'identity - :obj-end-indent t - :obj-end-fmtstr "
    • ~%" - :obj-end-value-func #'identity - :obj-data-indent t - :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)) (hyperobject-class-title x) nitems)) - -(defclass xmlformat (textformat) - () - (:default-initargs :file-start-str "" ; (std-xml-header) - :list-start-indent t - :list-start-fmtstr "<~a>~a~p: ~%" - :list-start-value-func #'xmlformat-list-start-value-func - :list-end-indent t - :list-end-fmtstr "~%" - :list-end-value-func #'xmlformat-list-end-value-func - :obj-start-fmtstr "<~a>" - :obj-start-value-func #'class-name-of - :obj-start-indent t - :obj-end-fmtstr "~%" - :obj-end-value-func #'class-name-of - :obj-end-indent nil - :obj-data-indent nil - :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) - (fmtstr-labels :type function :initarg :fmtstr-labels :accessor fmtstr-labels) - (page-name :type string :initarg :page-name :accessor page-name) - (href-head :type string :initarg :href-head :accessor href-head) - (href-end :type string :initarg :href-end :accessor href-end) - (ampersand :type string :initarg :ampersand :accessor ampersand)) - (:default-initargs :fmtstr nil - :fmtstr-labels nil - :page-name "disp-func1" - :href-head nil :href-end nil :ampersand nil) - (:documentation "Formatting for a linked reference")) - -(defclass html-link-ref (link-ref) - () - (: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 #'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 #'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 "&") - (:documentation "Mozilla's and W3's idea of a link with XML")) - -(defclass ie-xml-link-ref (xml-link-ref) - () - (:default-initargs :href-head "html:a href=" - :href-end "html:a" ) - (:documentation "Internet Explorer's idea of a link with XML")) - - -(defclass htmlrefformat (htmlformat) - () - (:default-initargs :link-ref (make-instance 'html-link-ref))) - -(defclass xhtmlrefformat (xhtmlformat) - () - (:default-initargs :link-ref (make-instance 'xhtml-link-ref))) - -(defclass xmlrefformat (xmlformat) - () - (:default-initargs :link-ref (make-instance 'xml-link-ref))) - -(defclass ie-xmlrefformat (xmlformat) - () - (:default-initargs :link-ref (make-instance 'ie-xml-link-ref))) - - -;;; File Start and Ends - -(defgeneric fmt-file-start (fmt s)) -(defmethod fmt-file-start ((fmt dataformat) (s stream))) - -(defmethod fmt-file-start ((fmt textformat) (s stream)) - (aif (file-start-str fmt) - (format s it))) - -(defgeneric fmt-file-end (fmt s)) -(defmethod fmt-file-end ((fmt textformat) (s stream)) - (aif (file-end-str fmt) - (format s it))) - -;;; List Start and Ends - -(defgeneric fmt-list-start (obj fmt s &optional indent num-items)) -(defmethod fmt-list-start (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) - (if (list-start-indent fmt) - (indent-spaces indent s)) - (aif (list-start-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (list-start-value-func fmt) x num-items))))) - -(defgeneric fmt-list-end (obj fmt s &optional indent num-items)) -(defmethod fmt-list-end (x (fmt textformat) (s stream) &optional (indent 0) (num-items 1)) - (declare (ignore num-items)) - (if (list-end-indent fmt) - (indent-spaces indent s)) - (aif (list-end-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (list-end-value-func fmt) x))))) - -;;; Object Start and Ends - -(defgeneric fmt-obj-start (obj fmt s &optional indent)) -(defmethod fmt-obj-start (x (fmt textformat) (s stream) &optional (indent 0)) - (if (obj-start-indent fmt) - (indent-spaces indent s)) - (aif (obj-start-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (obj-start-value-func fmt) x))))) - -(defgeneric fmt-obj-end (obj fmt s &optional indent)) -(defmethod fmt-obj-end (x (fmt textformat) (s stream) &optional (indent 0)) - (if (obj-end-indent fmt) - (indent-spaces indent s)) - (aif (obj-end-fmtstr fmt) - (apply #'format s it - (multiple-value-list - (funcall (obj-end-value-func fmt) x))))) - -;;; Object Data - -(defgeneric make-link-start (obj ref fieldname fieldfunc fieldvalue refvars)) -(defmethod make-link-start (obj (ref link-ref) fieldname fieldfunc fieldvalue refvars) - (declare (ignore obj fieldname)) - (format nil "~a\"~a?func=~a~akey=~a~a\"" - (href-head ref) (make-url (page-name ref)) fieldfunc - (ampersand ref) fieldvalue - (if refvars - (let ((varstr "")) - (dolist (var refvars) - (string-append varstr (format nil "~a~a=~a" - (ampersand ref) (car var) (cadr var)))) - varstr) - ""))) - -(defgeneric make-link-end (obj ref fieldname)) -(defmethod make-link-end (obj (ref link-ref) fieldname) - (declare (ignore obj fieldname)) - (format nil "~a" (href-end ref)) - ) - -(defgeneric fmt-obj-data (obj fmt s &optional indent label refvars)) -(defmethod fmt-obj-data (x (fmt textformat) s - &optional (indent 0) (label nil) (refvars nil)) - (if (obj-data-indent fmt) - (indent-spaces indent s)) - (if (link-ref fmt) - (fmt-obj-data-with-ref x fmt s label refvars) - (fmt-obj-data-plain x fmt s label)) - (aif (obj-data-end-fmtstr fmt) - (format s it))) - -(defgeneric fmt-obj-data-plain (obj fmt s label)) -(defmethod fmt-obj-data-plain (x (fmt textformat) s label) - (if label - (apply #'format s - (funcall (obj-data-fmtstr-labels fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))) - (apply #'format s (funcall (obj-data-fmtstr fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))))) - -(defgeneric fmt-obj-data-with-ref (obj fmt s label refvars)) -(defmethod fmt-obj-data-with-ref (x (fmt textformat) s label refvars) - (let ((refstr (make-ref-data-str x fmt label)) - (refvalues nil) - (field-values - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x)))) - - ;; make list of reference link fields for printing to refstr template - (dolist (ref (hyperobject-class-references x)) - (let ((link-start - (make-link-start x (link-ref fmt) (name ref) (lookup ref) - (nth (position (name ref) - (hyperobject-class-fields x) - :key #'(lambda (x) - (slot-definition-name x))) - field-values) - (append (link-parameters ref) refvars))) - (link-end (make-link-end x (link-ref fmt) (name ref)))) - (push link-start refvalues) - (push link-end refvalues))) - (setq refvalues (nreverse refvalues)) - - (apply #'format s refstr refvalues))) - -(defgeneric obj-data (obj)) -(defmethod obj-data (x) - "Returns the objects data as a string. Used by common-graphics outline function" - (let ((fmt (make-format-instance :text))) - (apply #'format nil (funcall (obj-data-fmtstr fmt) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))))) - -(defgeneric make-ref-data-str (obj fmt &optional label)) -(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil)) - "Return fmt string for that contains ~a slots for reference link start and end" - (unless (link-ref fmt) - (error "fmt does not contain a link-ref")) - (let ((refstr - (if label - (apply #'format nil (funcall (fmtstr-labels (link-ref fmt)) x) - (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) x) x))) - (apply #'format nil (funcall (fmtstr (link-ref fmt)) x) - (multiple-value-list (funcall (funcall (obj-data-value-func fmt) x) x)))))) - refstr)) - -;;; Display method for objects - - -(defgeneric load-all-subobjects (objs)) -(defmethod load-all-subobjects (objs) - "Load all subobjects if they have not already been loaded." - (when objs - (let ((objlist (mklist objs))) - (dolist (obj objlist) - (awhen (hyperobject-class-subobjects obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (reader child-obj) obj) - (load-all-subobjects it)))))) - objs)) - -(defgeneric print-hyperobject-class (objs fmt strm - &optional label english-only-function - indent subobjects refvars)) - -(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 hyperobject-class instances and their subobjects" - (when objs - (setq objs (mklist objs)) - (let ((nobjs (length objs))) - (fmt-list-start (car objs) fmt strm indent nobjs) - (dolist (obj objs) - (unless (and english-only-function - (multiple-value-bind (eng term) (funcall english-only-function obj) - (and term (not eng)))) - (fmt-obj-start obj fmt strm indent) - (fmt-obj-data obj fmt strm (1+ indent) label refvars) - (if subobjects - (awhen (hyperobject-class-subobjects obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (funcall (reader child-obj) obj) ;; access set of child objects - (print-hyperobject-class it fmt strm label - (1+ indent) english-only-function - subobjects refvars))))) - (fmt-obj-end obj fmt strm indent))) - (fmt-list-end (car objs) fmt strm indent nobjs)) - t)) - - - -(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 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 - (print-hyperobject-class objs fmt os label 0 english-only-function subobjects refvars)) - (if file-wrapper - (fmt-file-end fmt os))) - objs) - -- 2.34.1