From da95022a6396191e772e59cd7622c7c5919ce605 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 13 Dec 2002 05:44:50 +0000 Subject: [PATCH] r3613: *** empty log message *** --- base-class.lisp | 10 +- examples/person.lisp | 18 +- hyperobject.asd | 4 +- metaclass.lisp | 4 +- mop.lisp | 83 ++-- views.lisp | 886 +++++++++++++++++++------------------------ wrapper.lisp | 4 +- 7 files changed, 443 insertions(+), 566 deletions(-) diff --git a/base-class.lisp b/base-class.lisp index 1e3c5df..0da829b 100644 --- a/base-class.lisp +++ b/base-class.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: base-class.lisp,v 1.2 2002/12/02 15:57:17 kevin Exp $ +;;;; $Id: base-class.lisp,v 1.3 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -22,12 +22,10 @@ (:metaclass hyperobject-class) (:description "Basic 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 (obj-data-fmtstr fmt) obj) + (let ((view (get-category-view obj :compact-text))) + (apply #'format s (slot-value view 'obj-data-fmtstr) (multiple-value-list - (funcall (funcall (obj-data-value-func fmt) obj) obj)))))) + (funcall (slot-value view 'obj-data-value-func) obj)))))) diff --git a/examples/person.lisp b/examples/person.lisp index 81e37f4..f479250 100644 --- a/examples/person.lisp +++ b/examples/person.lisp @@ -9,7 +9,7 @@ ;;;; ;;;; A simple example file for hyperobjects ;;;; -;;;; $Id: person.lisp,v 1.1 2002/11/29 23:14:32 kevin Exp $ +;;;; $Id: person.lisp,v 1.2 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -21,14 +21,14 @@ (defclass person (hyperobject) ((first-name :type string :initarg :first-name :reader first-name) (last-name :type string :initarg :last-name :reader last-name - :reference find-person-by-last-name) + :hyperlink find-person-by-last-name) (dob :type integer :initarg :dob :reader dob :print-formatter format-date) (resume :type cdata :initarg :resume :reader resume) (addresses :initarg :addresses :reader addresses :subobject t)) (:metaclass hyperobject-class) (:default-initargs :first-name nil :last-name nil :dob 0 :resume nil) - (:print-slots first-name last-name dob resume) - (:title "Person") + (:default-print-slots first-name last-name dob resume) + (:user-name "Person") (:description "A Person")) (defun format-date (ut) @@ -49,17 +49,17 @@ (phones :initarg :phones :reader phones :subobject t)) (:metaclass hyperobject-class) (:default-initargs :title nil :street nil) - (:title "Address") - (:print-slots title street) + (:user-name "Address") + (:default-print-slots title street) (:description "An address")) (defclass phone (hyperobject) ((title :type string :initarg :title :reader title) (phone-number :type string :initarg :phone-number :reader phone-number)) (:metaclass hyperobject-class) - (:title "Phone Number") + (:user-name "Phone Number") (:default-initargs :title nil :phone-number nil) - (:print-slots title phone-number) + (:default-print-slots title phone-number) (:description "A phone number")) @@ -87,4 +87,4 @@ (view mary :subobjects t) (format t "~&XML Format with field labels and hyperlinks~%") -(view mary :subobjects t :label t :format :xmlref) +(view mary :subobjects t :category :xml-link-labels) diff --git a/hyperobject.asd b/hyperobject.asd index 07761da..76cef90 100644 --- a/hyperobject.asd +++ b/hyperobject.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: hyperobject.asd,v 1.14 2002/12/11 13:58:34 kevin Exp $ +;;;; $Id: hyperobject.asd,v 1.15 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -26,7 +26,7 @@ (:file "sql" :depends-on ("connect")) (:file "views" :depends-on ("mop")) (:file "base-class" :depends-on ("views")) - (:file "wrapper" :depends-on "base-class") + (:file "wrapper" :depends-on ("base-class")) ) :depends-on (:kmrcl :clsql)) diff --git a/metaclass.lisp b/metaclass.lisp index 2a632b5..b43f7e5 100644 --- a/metaclass.lisp +++ b/metaclass.lisp @@ -8,7 +8,7 @@ ;;;; Date Started: Apr 2000 ;;;; ;;;; -;;;; $Id: metaclass.lisp,v 1.3 2002/12/09 10:37:58 kevin Exp $ +;;;; $Id: metaclass.lisp,v 1.4 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -21,7 +21,7 @@ (defparameter *class-options* - '(:user-name :print-slots :description :version :sql-name) + '(:user-name :default-print-slots :description :version :sql-name) "List of class options for hyperobjects.") (defparameter *slot-options* '(:print-formatter :description :user-name diff --git a/mop.lisp b/mop.lisp index e315843..1094c56 100644 --- a/mop.lisp +++ b/mop.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: mop.lisp,v 1.9 2002/12/09 19:37:54 kevin Exp $ +;;;; $Id: mop.lisp,v 1.10 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -28,8 +28,8 @@ ( ;; slots initialized in defclass (user-name :initarg :user-name :type string :initform nil :documentation "User name for class") - (print-slots :initarg :print-slots :type list :initform nil - :documentation "List of slots to print") + (default-print-slots :initarg :default-print-slots :type list :initform nil + :documentation "Defaults slots for a view") (description :initarg :description :initform nil :documentation "Class description") (version :initarg :version :initform nil @@ -45,23 +45,16 @@ "List of fields that have hyperlinks") (class-id :type integer :initform nil :documentation "Unique ID for the class") - + + ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) (create-indices-cmds :initform nil :reader create-index-cmds) (drop-table-cmd :initform nil :reader drop-table-cmd) - (value-func :initform nil :type function) - (xmlvalue-func :initform nil :type function) - (fmtstr-text :initform nil :type string) - (fmtstr-html :initform nil :type string) - (fmtstr-xml :initform nil :type string) - (fmtstr-text-labels :initform nil :type string) - (fmtstr-html-labels :initform nil :type string) - (fmtstr-xml-labels :initform nil :type string) - (fmtstr-html-ref :initform nil :type string) - (fmtstr-xml-ref :initform nil :type string) - (fmtstr-html-ref-labels :initform nil :type string) - (fmtstr-xml-ref-labels :initform nil :type string) + (views :type list :initform nil :initarg :views :accessor views + :documentation "List of views") + (default-view :initform nil :initarg :default-view :accessor default-view + :documentation "The default view for a class") ) (:documentation "Metaclass for Markup Language classes.")) @@ -93,7 +86,8 @@ t) (defmethod finalize-inheritance :after ((cl hyperobject-class)) - (init-hyperobject-class cl)) + (init-hyperobject-class cl) + ) ;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) @@ -305,10 +299,22 @@ (format nil "~%Class description: ~A" it) "") (aif (slot-value cl 'subobjects) (format nil "~%Subobjects:~{ ~A~}" (mapcar #'name-slot it)) "") - (aif (slot-value cl 'print-slots) - (format nil "~%Print-slots:~{ ~A~}" it) "") + (aif (slot-value cl 'default-print-slots) + (format nil "~%Default print slots:~{ ~A~}" it) "") )))) +(defun finalize-hyperlinks (cl) + (let ((hyperlinks '())) + (dolist (esd (class-slots cl)) + (awhen (slot-value esd 'hyperlink) + (push + (make-instance 'hyperlink + :name (slot-definition-name esd) + :lookup it + :link-parameters (slot-value esd 'hyperlink-parameters)) + hyperlinks))) + (setf (slot-value cl 'hyperlinks) hyperlinks))) + (defun init-hyperobject-class (cl) "Initialize a hyperobject class. Calculates all class slots" (finalize-subobjects cl) @@ -325,30 +331,6 @@ (defun find-slot-by-name (cl name) (find name (class-slots cl) :key #'slot-definition-name)) -(defun hyperobject-class-fmtstr-text (obj) - (slot-value (class-of obj) 'fmtstr-text)) - -(defun hyperobject-class-fmtstr-html (obj) - (slot-value (class-of obj) 'fmtstr-html)) - -(defun hyperobject-class-fmtstr-xml (obj) - (slot-value (class-of obj) 'fmtstr-xml)) - -(defun hyperobject-class-fmtstr-text-labels (obj) - (slot-value (class-of obj) 'fmtstr-text-labels)) - -(defun hyperobject-class-fmtstr-html-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-labels)) - -(defun hyperobject-class-fmtstr-xml-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-labels)) - -(defun hyperobject-class-value-func (obj) - (slot-value (class-of obj) 'value-func)) - -(defun hyperobject-class-xmlvalue-func (obj) - (slot-value (class-of obj) 'xmlvalue-func)) - (defun hyperobject-class-user-name (obj) (awhen (slot-value (class-of obj) 'user-name) (if (consp it) @@ -364,18 +346,3 @@ (defun hyperobject-class-fields (obj) (class-slots (class-of obj))) -(defun hyperobject-class-print-slots (obj) - (slot-value (class-of obj) 'print-slots)) - -(defun hyperobject-class-fmtstr-html-ref (obj) - (slot-value (class-of obj) 'fmtstr-html-ref)) - -(defun hyperobject-class-fmtstr-xml-ref (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref)) - -(defun hyperobject-class-fmtstr-html-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-html-ref-labels)) - -(defun hyperobject-class-fmtstr-xml-ref-labels (obj) - (slot-value (class-of obj) 'fmtstr-xml-ref-labels)) - diff --git a/views.lisp b/views.lisp index a80c1e9..e30b0eb 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.11 2002/12/09 10:39:38 kevin Exp $ +;;;; $Id: views.lisp,v 1.12 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -19,286 +19,292 @@ (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2)))) +(defclass object-view () + ((object-class :initform nil :initarg :object-class + :documentation "Name of class for object to be viewed.") + (slots :initform nil :initarg :slots + :documentation "List of effective slots for object to be viewed.") + (name :initform nil :initarg :name + :documentation "Name for this view.") + (category :initform nil :initarg :category :reader category + :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.") + (source-code :initform nil :initarg :source-code + :documentation "Source code for generating view.") + (country-language :initform :en :initarg :country-language + :documentation "Country's Language for this view.") + ;; + (file-start-str :type string :initform nil :initarg :file-start-str) + (file-end-str :type string :initform nil :initarg :file-end-str) + (list-start-fmtstr :type string :initform nil :initarg :list-start-fmtstr) + (list-start-value-func :type function :initform nil + :initarg :list-start-value-func) + (list-start-indent :initform nil :initarg :list-start-indent) + (list-end-fmtstr :type string :initform nil :initarg :list-end-fmtstr) + (list-end-value-func :type function :initform nil + :initarg :list-end-value-func) + (list-end-indent :initform nil :initarg :list-end-indent) + (obj-start-fmtstr :type string :initform nil :initarg :obj-start-fmtstr) + (obj-start-value-func :initform nil :initarg :obj-start-value-func) + (obj-start-indent :initform nil :initarg :obj-start-indent) + (obj-end-fmtstr :type string :initform nil :initarg :obj-end-fmtstr) + (obj-end-value-func :type function :initform nil + :initarg :obj-end-value-func) + (obj-end-indent :initform nil :initarg :obj-end-indent) + (obj-data-indent :initform nil :initarg :obj-data-indent) + (obj-data-fmtstr :type string :initform nil :initarg :obj-data-fmtstr) + (obj-data-end-fmtstr :type string :initform nil + :initarg :obj-data-end-fmtstr) + (obj-data-value-func :type function :initform nil + :initarg :obj-data-value-func) + + (link-slots :type list :initform nil + :documentation "List of slot names that have hyperlinks") + (link-page-name :type string :initform nil :initarg :link-page-name) + (link-href-start :type string :initform nil :initarg :link-href-start) + (link-href-end :type string :initform nil :initarg :link-href-end) + (link-ampersand :type string :initform nil :initarg :link-ampersand)) + (:default-initargs :link-page-name "disp-func1") + (:documentation "View class for a hyperobject")) + + +(defun get-category-view (obj category &optional slots) + "Find or make a category view for an object" + (let ((obj-class (class-of obj))) + (if (null category) + (slot-value obj-class 'default-view) + (aif (find category (views obj-class) :key #'category) + it + (let ((view + (make-instance 'object-view :object-class (class-name obj-class) + :category category + :slots slots))) + (push view (views obj-class)) + view))))) + ;;;; ************************************************************************* ;;;; Metaclass Intialization ;;;; ************************************************************************* -(defun finalize-hyperlinks (cl) - (let ((hyperlinks '())) - (dolist (esd (class-slots cl)) - (awhen (slot-value esd 'hyperlink) - (push - (make-instance 'hyperlink - :name (slot-definition-name esd) - :lookup it - :link-parameters (slot-value esd 'hyperlink-parameters)) - hyperlinks))) - (setf (slot-value cl 'hyperlinks) hyperlinks))) - - (defun finalize-views (cl) + "Finalize all views that are given on a objects initialization" + (unless (slot-value cl 'default-print-slots) + (setf (slot-value cl 'default-print-slots) + (mapcar #'slot-definition-name (class-slots cl)))) + (let ((views '())) + (dolist (view-def (slot-value cl 'views)) + (push (make-object-view cl view-def) views)) + (setf (slot-value cl 'views) (nreverse views))) + (cond + ((default-view cl) + (setf (slot-value cl 'default-view) (make-object-view cl (default-view cl)))) + ((car (views cl)) + (setf (slot-value cl 'default-view) (make-object-view cl (car (views cl))))) + (t + (setf (slot-value cl 'default-view) (make-object-view cl :default))))) + +(defun make-object-view (cl view-def) + "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op" + (cond + ((typep view-def 'object-view) + view-def) + ((eq view-def :default) + (let* ((name (class-name cl)) + (view (make-instance 'object-view :name "automatic" + :object-class name + :category :compact-text))) + view)) + ((consp view-def) + (eval `(make-instance ,view-def))) + (t + (error "Invalid parameter to make-object-view: ~S" view-def)))) + +(defmethod initialize-instance :after ((view object-view) + &rest initargs &key &allow-other-keys) + (initialize-view (find-class (slot-value view 'object-class)) view)) + +(defun initialize-view (obj-cl view) "Calculate all view slots for a hyperobject class" - (let ((fmtstr-text "") - (fmtstr-html "") - (fmtstr-xml "") - (fmtstr-text-labels "") - (fmtstr-html-labels "") - (fmtstr-xml-labels "") - (fmtstr-html-ref "") - (fmtstr-xml-ref "") - (fmtstr-html-ref-labels "") - (fmtstr-xml-ref-labels "") + (let ((fmtstr nil) (first-field t) (value-func '()) - (xmlvalue-func '()) - (classname (class-name cl)) - (package (symbol-package (class-name cl))) - (hyperlinks nil)) - (declare (ignore classname)) - (check-type (slot-value cl 'print-slots) list) - (dolist (slot-name (slot-value cl 'print-slots)) - (let ((slot (find-slot-by-name cl slot-name))) + (links '()) + (category (category view))) + (unless (slot-value view 'slots) + (setf (slot-value view 'slots) (slot-value obj-cl 'default-print-slots))) + (dolist (slot-name (slot-value view 'slots)) + (let ((slot (find-slot-by-name obj-cl slot-name))) (unless slot - (error "Slot ~A is not found in class ~S" slot-name cl)) + (error "Slot ~A is not found in class ~S" slot-name obj-cl)) (let ((name (slot-definition-name slot)) - (namestr (symbol-name (slot-definition-name slot))) (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) - (type (slot-value slot 'ho-type)) - (print-formatter (slot-value slot 'print-formatter)) - (value-fmt "~a") - (plain-value-func nil) - html-str xml-str html-label-str xml-label-str) - - (when (or (eql type :integer) (eql type :fixnum)) - (setq value-fmt "~d")) - - (when (eql type :boolean) - (setq value-fmt "~a")) - - (if first-field - (setq first-field nil) - (progn - (string-append fmtstr-text " ") - (string-append fmtstr-html " ") - (string-append fmtstr-xml " ") - (string-append fmtstr-text-labels " ") - (string-append fmtstr-html-labels " ") - (string-append fmtstr-xml-labels " ") - (string-append fmtstr-html-ref " ") - (string-append fmtstr-xml-ref " ") - (string-append fmtstr-html-ref-labels " ") - (string-append fmtstr-xml-ref-labels " "))) - - (setq html-str (concatenate 'string "" value-fmt "")) - (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "")) - (setq html-label-str (concatenate 'string "" namestr-lower " " value-fmt "")) - (setq xml-label-str (concatenate 'string " <" namestr-lower ">" value-fmt "")) - - (string-append fmtstr-text value-fmt) - (string-append fmtstr-html html-str) - (string-append fmtstr-xml xml-str) - (string-append fmtstr-text-labels namestr-lower " " value-fmt) - (string-append fmtstr-html-labels html-label-str) - (string-append fmtstr-xml-labels xml-label-str) - - (if (slot-value slot 'hyperlink) - (progn - (string-append fmtstr-html-ref "<~~a>" value-fmt "") - (string-append fmtstr-xml-ref "<~~a>" value-fmt "") - (string-append fmtstr-html-ref-labels "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr-xml-ref-labels " <~~a>" value-fmt "") - (push (make-instance 'hyperlink :name name - :lookup (slot-value slot 'hyperlink)) - hyperlinks)) - (progn - (string-append fmtstr-html-ref html-str) - (string-append fmtstr-xml-ref xml-str) - (string-append fmtstr-html-ref-labels html-label-str) - (string-append fmtstr-xml-ref-labels xml-label-str))) + (type (slot-value slot 'type)) + (print-formatter (slot-value slot 'print-formatter))) + + (cond + (first-field + (setq fmtstr "") + (setq first-field nil)) + (t + (string-append fmtstr " "))) + + (when (slot-value slot 'hyperlink) + (push name links)) - (if print-formatter - (setq plain-value-func - (list `(,print-formatter (slot-value x ',(intern namestr package))))) - (setq plain-value-func - (list `(slot-value x ',(intern namestr package))))) - (setq value-func (append value-func plain-value-func)) + (let ((value-fmt + (case type + ((or :integer :fixnum) + "~d") + (:boolean + "~a") + (otherwise + "~a")))) + (case category + (:compact-text + (string-append fmtstr value-fmt)) + (:compact-text-labels + (string-append fmtstr namestr-lower " " value-fmt)) + ((or :html :xhtml) + (string-append fmtstr (concatenate 'string "" value-fmt ""))) + (:xml + (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt ""))) + (:html-label + (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt ""))) + (:xhtml-label + (string-append fmtstr (concatenate 'string " " value-fmt ""))) + (:xml-labels + (string-append fmtstr (concatenate 'string " <" namestr-lower ">" value-fmt ""))) + ((or :html-link :xhtml-link) + (if (slot-value slot 'hyperlink) + (string-append fmtstr "<~~a>" value-fmt "") + (string-append fmtstr (concatenate 'string "" value-fmt "")))) + (:xml-link + (if (slot-value slot 'hyperlink) + (string-append fmtstr "<~~a>" value-fmt "") + (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "")))) + (:html-link-labels + (if (slot-value slot 'hyperlink) + (string-append fmtstr "" namestr-lower " <~~a>" value-fmt "") + (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt "")))) + (:xhtml-link-labels + (if (slot-value slot 'hyperlink) + (string-append fmtstr "<[!CDATA[" namestr-lower "]]> <~~a>" value-fmt "") + (string-append fmtstr (concatenate 'string " " value-fmt "")))) + (:xml-link-labels + (if (slot-value slot 'hyperlink) + (string-append fmtstr " <~~a>" value-fmt "") + (string-append fmtstr (concatenate 'string " <" namestr-lower ">" value-fmt ""))))) + ) ;; let value-fmt - (if (eql type :cdata) - (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) - (setq xmlvalue-func (append xmlvalue-func plain-value-func))) + (let ((func (if print-formatter + `(,print-formatter (slot-value x (quote ,name))) + `(slot-value x (quote ,name))))) + (when (and (in category :xml :xhtml :xml-link :xhtml-link + :xhtml-link-labels :xml-link-labels :ie-xml-link + :ie-xml-link-labels) + (or print-formatter + (string-equal (write-to-string type) "string"))) + (setq func `(kmrcl:xml-cdata ,func))) + (push func value-func)) ))) + + (when value-func + (setq value-func + (compile nil (eval `(lambda (x) (values ,@(nreverse value-func))))))) + + (setf (slot-value view 'obj-data-fmtstr) fmtstr) + (setf (slot-value view 'obj-data-value-func) value-func) + (setf (slot-value view 'link-slots) (nreverse links)) - (setf (slot-value cl 'hyperlinks) hyperlinks) - - (if value-func - (setq value-func `(lambda (x) (values ,@value-func))) - (setq value-func `(lambda () (values)))) - (setq value-func (compile nil (eval value-func))) - - (if xmlvalue-func - (setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func))) - (setq xmlvalue-func `(lambda () (values)))) - (setq xmlvalue-func (compile nil (eval xmlvalue-func))) - - (setf (slot-value cl 'fmtstr-text) fmtstr-text) - (setf (slot-value cl 'fmtstr-html) fmtstr-html) - (setf (slot-value cl 'fmtstr-xml) fmtstr-xml) - (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels) - (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels) - (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels) - (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref) - (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref) - (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels) - (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels) - (setf (slot-value cl 'value-func) value-func) - (setf (slot-value cl 'xmlvalue-func) xmlvalue-func)) - (values)) + (case category + ((or :compact-text :compact-text-labels) + (initialize-text-view view)) + ((or :html :xhtml :html-labels :xhtml-labels) + (initialize-html-view view)) + ((or :xml :xml-labels) + (initialize-xml-view view)) + ((or :html-link :html-link-labels) + (initialize-html-view view) + (setf (slot-value view 'link-href-start) "a href=") + (setf (slot-value view 'link-href-end) "a") + (setf (slot-value view 'link-ampersand) "&")) + ((or :xhtml-link :xhtml-link-labels) + (initialize-html-view view) + (setf (slot-value view 'link-href-start) "a href=") + (setf (slot-value view 'link-href-end) "a") + (setf (slot-value view 'link-ampersand) "&")) + ((or :xml-link :xml-link-labels) + (initialize-xml-view view) + (setf (slot-value view 'link-href-start) + "xmllink xlink:type=\"simple\" xlink:href=") + (setf (slot-value view 'link-href-end) "xmllink") + (setf (slot-value view 'link-ampersand) "&")) + ((or :ie-xml-link :ie-xml-link-labels) + (initialize-xml-view view) + (setf (slot-value view 'link-href-start) "html:a href=") + (setf (slot-value view 'link-href-end) "html:a") + (setf (slot-value view 'link-ampersand) "&")))) + view) ;;;; ************************************************************************* ;;;; View Data Format Section ;;;; ************************************************************************* -(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 class-name-of (obj) + (string-downcase (class-name (class-of obj)))) (defun text-list-start-value-func (obj nitems) (values (hyperobject-class-user-name 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-user-name 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 initialize-text-view (view) + (setf (slot-value view 'list-start-fmtstr) "~a~P:~%") + (setf (slot-value view 'list-start-value-func) #'text-list-start-value-func) + (setf (slot-value view 'list-start-indent) t) + (setf (slot-value view 'obj-data-indent) t) + (setf (slot-value view 'obj-data-end-fmtstr) "~%")) + +(defun initialize-html-view (view) + (initialize-text-view view) + (setf (slot-value view 'file-start-str) "~%") + (setf (slot-value view 'file-end-str) "~%") + (setf (slot-value view 'list-start-indent) t) + (setf (slot-value view 'list-start-fmtstr) + "

    ~a~p:

    ~%") + (setf (slot-value view 'list-end-indent) t) + (setf (slot-value view 'list-end-value-func) nil) + (setf (slot-value view 'obj-start-indent) t) + (setf (slot-value view 'obj-start-fmtstr) "
  • ") + (setf (slot-value view 'obj-start-value-func) nil) + (setf (slot-value view 'obj-end-indent) t) + (setf (slot-value view 'obj-end-fmtstr) "
    • ~%") + (setf (slot-value view 'obj-end-value-func) nil) + (setf (slot-value view 'obj-data-indent) t)) + +(defun initialize-xhtml-view (view) + (initialize-text-view view) + (setf (slot-value view 'file-start-str) "~%") + (setf (slot-value view 'file-end-str) "~%") + (setf (slot-value view 'list-start-indent) t) + (setf (slot-value view 'list-start-fmtstr) + "

    ~a~p:

    ~%") + (setf (slot-value view 'list-end-indent) t) + (setf (slot-value view 'list-end-value-func) nil) + (setf (slot-value view 'obj-start-indent) t) + (setf (slot-value view 'obj-start-fmtstr) "
  • ") + (setf (slot-value view 'obj-start-value-func) nil) + (setf (slot-value view 'obj-end-indent) t) + (setf (slot-value view 'obj-end-fmtstr) "
    • ~%") + (setf (slot-value view 'obj-end-value-func) nil) + (setf (slot-value view 'obj-data-indent) t)) (defun xmlformat-list-end-value-func (x) (format nil "~alist" (class-name-of x))) @@ -306,280 +312,184 @@ (defun xmlformat-list-start-value-func (x nitems) (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name 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 hyperlink")) - -(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))) +(defun initialize-xml-view (view) + (initialize-text-view view) + (setf (slot-value view 'file-start-str) "") ; (std-xml-header) + (setf (slot-value view 'list-start-indent) t) + (setf (slot-value view 'list-start-fmtstr) "<~a>~a~p: ~%") + (setf (slot-value view 'list-start-value-func) + #'xmlformat-list-start-value-func) + (setf (slot-value view 'list-end-indent) t) + (setf (slot-value view 'list-end-fmtstr) "~%") + (setf (slot-value view 'list-end-value-func) #'xmlformat-list-end-value-func) + (setf (slot-value view 'obj-start-fmtstr) "<~a>") + (setf (slot-value view 'obj-start-value-func) #'class-name-of) + (setf (slot-value view 'obj-start-indent) t) + (setf (slot-value view 'obj-end-fmtstr) "~%") + (setf (slot-value view 'obj-end-value-func) #'class-name-of) + (setf (slot-value view 'obj-end-indent) nil) + (setf (slot-value view 'obj-data-indent) nil)) ;;; 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))) +(defun fmt-file-start (view strm) + (awhen (slot-value view 'file-start-str) + (format strm it))) -(defgeneric fmt-file-end (fmt s)) -(defmethod fmt-file-end ((fmt textformat) (s stream)) - (aif (file-end-str fmt) - (format s it))) +(defun fmt-file-end (view strm) + (awhen (slot-value view 'file-end-str) + (format strm 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)) +(defun fmt-list-start (obj view strm indent num-items) + (when (slot-value view 'list-start-indent) + (indent-spaces indent strm)) + (let-when (fmtstr (slot-value view 'list-start-fmtstr)) + (let-if (value-func (slot-value view 'list-start-value-func)) + (apply #'format strm fmtstr + (multiple-value-list (funcall value-func + obj num-items))) + (format strm fmtstr)))) + +(defun fmt-list-end (obj view strm indent num-items) (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))))) + (when (slot-value view 'list-end-indent) + (indent-spaces indent strm)) + (let-when (fmtstr (slot-value view 'list-end-fmtstr)) + (let-if (value-func (slot-value view 'list-end-value-func)) + (apply #'format strm fmtstr (multiple-value-list + (funcall value-func obj))) + (format strm fmtstr)))) ;;; 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))))) +(defun fmt-obj-start (obj view strm indent) + (when (slot-value view 'obj-start-indent) + (indent-spaces indent strm)) + (let-when (fmtstr (slot-value view 'obj-start-fmtstr)) + (let-if (value-func (slot-value view 'obj-start-value-func)) + (apply #'format strm fmtstr (multiple-value-list + (funcall value-func obj))) + (format strm fmtstr)))) + +(defun fmt-obj-end (obj view strm indent) + (when (slot-value view 'obj-end-indent) + (indent-spaces indent strm)) + (let-when (fmtstr (slot-value view 'obj-end-fmtstr)) + (let-if (value-func (slot-value view 'obj-end-value-func)) + (apply #'format strm fmtstr (multiple-value-list + (funcall value-func obj))) + (format strm fmtstr)))) ;;; 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)) +(defun make-link-start (view fieldfunc fieldvalue refvars) (format nil "~a\"~a?func=~a~akey=~a~a\"" - (href-head ref) (make-url (page-name ref)) fieldfunc - (ampersand ref) fieldvalue + (slot-value view 'link-href-start) + (make-url (slot-value view 'link-page-name)) + fieldfunc + (slot-value view 'link-ampersand) fieldvalue (if refvars (let ((varstr "")) (dolist (var refvars) - (string-append varstr (format nil "~a~a=~a" - (ampersand ref) (car var) (cadr var)))) + (string-append + varstr (slot-value view 'ampersand) + (format nil "~a=~a" (car var) (cadr var)))) varstr) - ""))) + ""))) -(defgeneric make-link-end (obj ref fieldname)) -(defmethod make-link-end (obj (ref link-ref) fieldname) +(defun make-link-end (obj view fieldname) (declare (ignore obj fieldname)) - (format nil "~a" (href-end ref)) + ;;(format nil "~a" (href-end ref)) + (slot-value view 'link-href-end) ) -(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) +(defun fmt-obj-data (obj view strm indent refvars) + (when (slot-value view 'obj-data-indent) + (indent-spaces indent strm)) + (if (slot-value view 'link-slots) + (fmt-obj-data-with-link obj view strm refvars) + (fmt-obj-data-plain obj view strm)) + (awhen (slot-value view 'obj-data-end-fmtstr) + (format strm it))) + +(defun fmt-obj-data-plain (obj view strm) + (awhen (slot-value view 'obj-data-value-func) + (apply #'format strm (slot-value view 'obj-data-fmtstr) + (multiple-value-list (funcall it obj))))) + +(defun fmt-obj-data-with-link (obj view strm refvars) (let ((refvalues '())) ;; make list of hyperlink link fields for printing to refstr template - (dolist (name (hyperobject-class-print-slots x)) - (let-when (hyperlink (find name (hyperobject-class-hyperlinks x) :key #'name)) - (push (make-link-start x (link-ref fmt) name (lookup hyperlink) - (slot-value x name) + (dolist (name (slot-value view 'link-slots)) + (let ((hyperlink + (find name (hyperobject-class-hyperlinks obj) :key #'name))) + (push (make-link-start view (lookup hyperlink) (slot-value obj name) (append (link-parameters hyperlink) refvars)) refvalues) - (push (make-link-end x (link-ref fmt) name) refvalues))) + (push (make-link-end obj view name) refvalues))) (setq refvalues (nreverse refvalues)) - (apply #'format s (make-ref-data-str x fmt label) refvalues))) + (apply #'format strm (make-link-data-str obj view) refvalues))) -(defgeneric obj-data (obj)) -(defmethod obj-data (x) +(defun obj-data (obj view) "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))))) + (awhen (slot-value view 'obj-data-value-func) + (apply #'format nil (funcall (slot-value view 'obj-data-fmtstr)) + (multiple-value-list (funcall it obj))))) -(defgeneric make-ref-data-str (obj fmt &optional label)) -(defmethod make-ref-data-str (x (fmt textformat) &optional (label nil)) +(defun make-link-data-str (obj view) "Return fmt string for that contains ~a slots for hyperlink 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)) - + (awhen (slot-value view 'obj-data-value-func) + (apply #'format nil (slot-value view 'obj-data-fmtstr) + (multiple-value-list (funcall it obj))))) + ;;; Display method for objects -(defgeneric load-all-subobjects (objs)) -(defmethod load-all-subobjects (objs) +(defun load-all-subobjects (objs) "Load all subobjects if they have not already been loaded." - (when objs - (let ((objlist (mklist objs))) + (dolist (obj (mklist objs)) + (dolist (subobj (hyperobject-class-subobjects obj)) + (awhen (slot-value obj (name-slot subobj)) + (load-all-subobjects it)))) + objs) + +(defun view-hyperobject (objs view category strm &optional (indent 0) filter + subobjects refvars) + "Display a single or list of hyperobject-class instances and their subobjects" + (let-when (objlist (mklist objs)) + (let ((nobjs (length objlist))) + (fmt-list-start (car objlist) view strm indent nobjs) (dolist (obj objlist) - (awhen (hyperobject-class-subobjects obj) ;; access list of functions - (dolist (child-obj it) ;; for each child function - (awhen (slot-value obj (name-slot child-obj)) - (load-all-subobjects it)))))) - objs)) - -(defgeneric view-hyperobject (objs fmt strm - &optional label english-only-function - indent subobjects refvars)) - -(defmethod view-hyperobject (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 (slot-value obj (name-slot child-obj)) ;; access set of child objects - (view-hyperobject 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 view (objs &key (os *standard-output*) (format :text) - (label nil) (english-only-function nil) - (subobjects nil) (file-wrapper t) (refvars nil)) + (unless (and filter (not (funcall filter obj))) + (fmt-obj-start obj view strm indent) + (fmt-obj-data obj view strm (1+ indent) refvars) + (when (and subobjects (hyperobject-class-subobjects obj)) + (dolist (subobj (hyperobject-class-subobjects obj)) + (aif (slot-value obj (name-slot subobj)) + (view-hyperobject it (get-category-view (car (mklist it)) category) + category strm (1+ indent) filter + subobjects refvars)))) + (fmt-obj-end obj view strm indent))) + (fmt-list-end (car objlist) view strm indent nobjs))) + objs) + + +(defun view (objs &key (stream *standard-output*) category view + filter subobjects refvars file-wrapper) "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject" - (let ((fmt (make-format-instance format))) - (if file-wrapper - (fmt-file-start fmt os)) - (when objs - (view-hyperobject objs fmt os label 0 english-only-function subobjects refvars)) - (if file-wrapper - (fmt-file-end fmt os))) + (let-when (objlist (mklist objs)) + (when category + (setq view (get-category-view (car objlist) category))) + (unless view + (setq view (default-view (class-of (car objlist))))) + (when file-wrapper + (fmt-file-start view stream)) + (view-hyperobject objlist view category stream 0 filter subobjects refvars) + (when file-wrapper + (fmt-file-end view stream))) objs) diff --git a/wrapper.lisp b/wrapper.lisp index 6891663..6e67805 100644 --- a/wrapper.lisp +++ b/wrapper.lisp @@ -7,8 +7,10 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: wrapper.lisp,v 1.1 2002/12/11 13:58:34 kevin Exp $ +;;;; $Id: wrapper.lisp,v 1.2 2002/12/13 05:44:19 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* +(in-package :hyperobject) + -- 2.34.1