X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=views.lisp;h=fcd132d647aab0108c1cf5e05b63150961ad57fb;hp=8d43e6995ac21af847bb9fa4d7df8d7f9fd38b20;hb=HEAD;hpb=7bca13c10f4aee6affb132b7016a693dee9116c9 diff --git a/views.lisp b/views.lisp index 8d43e69..fcd132d 100644 --- a/views.lisp +++ b/views.lisp @@ -11,84 +11,84 @@ ;;;; ;;;; This file is Copyright (c) 2000-2004 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) (defclass object-view () ((object-class :initform nil :initarg :object-class - :accessor object-class - :documentation "Class of object to be viewed.") + :accessor object-class + :documentation "Class of object to be viewed.") (slots :initform nil :initarg :slots :accessor slots - :documentation "List of effective slots for object to be viewed.") + :documentation "List of effective slots for object to be viewed.") (id :initform nil :initarg :id :accessor id :documentation "id for this view.") - (source-code :initform nil :initarg :source-code :accessor source-code - :documentation "Source code for generating view.") + (source-code :initform nil :initarg :source-code :accessor source-code + :documentation "Source code for generating view.") (country-language :initform :en :initarg :country-language - :documentation "Country's Language for this view.") + :documentation "Country's Language for this view.") (printer :initform nil :initarg :printer :accessor printer - :documentation "default function that prints the object") + :documentation "default function that prints the object") ;; (file-start-str :type (or string null) :initform nil :initarg :file-start-str - :accessor file-start-str) + :accessor file-start-str) (file-end-str :type (or string null) :initform nil :initarg :file-end-str - :accessor file-end-str) + :accessor file-end-str) (list-start-printer :type (or string function null) :initform nil - :initarg :list-start-printer - :accessor list-start-printer) + :initarg :list-start-printer + :accessor list-start-printer) (list-start-indent :initform nil :initarg :list-start-indent - :accessor list-start-indent) + :accessor list-start-indent) (list-end-printer :type (or string function null) :initform nil - :initarg :list-end-printer - :accessor list-end-printer) + :initarg :list-end-printer + :accessor list-end-printer) (list-end-indent :initform nil :initarg :list-end-indent - :accessor list-end-indent) + :accessor list-end-indent) (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer - :accessor obj-start-printer) + :accessor obj-start-printer) (obj-start-indent :initform nil :initarg :obj-start-indent - :accessor obj-start-indent) + :accessor obj-start-indent) (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer - :accessor obj-end-printer) + :accessor obj-end-printer) (obj-end-indent :initform nil :initarg :obj-end-indent - :accessor obj-end-indent) + :accessor obj-end-indent) (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer - :accessor subobj-start-printer) + :accessor subobj-start-printer) (subobj-start-indent :initform nil :initarg :subobj-start-indent - :accessor subobj-start-indent) + :accessor subobj-start-indent) (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer - :accessor subobj-end-printer) + :accessor subobj-end-printer) (subobj-end-indent :initform nil :initarg :subobj-end-indent - :accessor subobj-end-indent) + :accessor subobj-end-indent) (obj-data-indent :initform nil :initarg :obj-data-indent - :accessor obj-data-indent) + :accessor obj-data-indent) (obj-data-printer :type (or function null) :initform nil - :initarg :obj-data-printer - :accessor obj-data-printer) - (obj-data-print-code :type (or function null) :initform nil - :initarg :obj-data-print-code - :accessor obj-data-print-code) + :initarg :obj-data-printer + :accessor obj-data-printer) + (obj-data-print-code :type (or function list null) :initform nil + :initarg :obj-data-print-code + :accessor obj-data-print-code) (obj-data-start-printer :type (or function string null) :initform nil - :initarg :obj-data-start-printer - :accessor obj-data-start-printer) + :initarg :obj-data-start-printer + :accessor obj-data-start-printer) (obj-data-end-printer :type (or string null) :initform nil - :initarg :obj-data-end-printer - :accessor obj-data-end-printer) + :initarg :obj-data-end-printer + :accessor obj-data-end-printer) (indenter :type (or function null) :initform nil - :accessor indenter - :documentation "Function that performs hierarchical indenting") + :accessor indenter + :documentation "Function that performs hierarchical indenting") (link-slots :type list :initform nil - :documentation "List of slot names that have hyperlinks" - :accessor link-slots) + :documentation "List of slot names that have hyperlinks" + :accessor link-slots) (link-page :type (or string null) :initform nil - :initarg :link-page - :accessor link-page) + :initarg :link-page + :accessor link-page) (link-href-start :type (or string null) :initform nil :initarg :link-href-start - :accessor link-href-start) + :accessor link-href-start) (link-href-end :type (or string null) :initform nil :initarg :link-href-end - :accessor link-href-end) + :accessor link-href-end) (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand - :accessor link-ampersand)) + :accessor link-ampersand)) (:default-initargs :link-page "meta-search.html") (:documentation "View class for a hyperobject")) @@ -101,32 +101,32 @@ "Looks for a view in class and parent classes" (when (typep obj-cl 'hyperobject-class) (aif (find vid (views obj-cl) :key #'id :test #'eq) - it - (let (cpl) - (handler-case - (setq cpl (class-precedence-list obj-cl)) - (error (e) - (declare (ignore e)) - ;; can't get cpl unless class finalized - (make-instance (class-name obj-cl)) - (setq cpl (class-precedence-list obj-cl)))) - (find-view-id-in-class-precedence (second cpl) vid))))) - - + it + (let (cpl) + (handler-case + (setq cpl (class-precedence-list obj-cl)) + (error (e) + (declare (ignore e)) + ;; can't get cpl unless class finalized + (make-instance (class-name obj-cl)) + (setq cpl (class-precedence-list obj-cl)))) + (find-view-id-in-class-precedence (second cpl) vid))))) + + (defun get-view-id (obj vid &optional slots) "Find or make a category view for an object" (let ((obj-cl (class-of obj))) (unless vid (setq vid (get-default-view-id obj-cl))) (aif (find-view-id-in-class-precedence obj-cl vid) - it - (let ((view - (make-instance 'object-view - :object-class (class-name obj-cl) - :id vid - :slots slots))) - (push view (views obj-cl)) - view)))) + it + (let ((view + (make-instance 'object-view + :object-class (class-name obj-cl) + :id vid + :slots slots))) + (push view (views obj-cl)) + view)))) ;;;; ************************************************************************* ;;;; Metaclass Intialization @@ -136,10 +136,10 @@ "Finalize all views that are given on a objects initialization" (unless (default-print-slots cl) (setf (default-print-slots cl) - (mapcar #'slot-definition-name (class-slots cl)))) + (mapcar #'slot-definition-name (class-slots cl)))) (setf (views cl) (loop for view-def in (direct-views cl) - collect (make-object-view cl view-def)))) + collect (make-object-view cl view-def)))) (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" @@ -147,24 +147,25 @@ ((typep view-def 'object-view) view-def) ((eq view-def :default) - (make-instance 'object-view + (make-instance 'object-view :object-class (class-name cl) :id :compact-text)) ((consp view-def) (make-instance 'object-view - :object-class (class-name cl) - :id (getf view-def :id) - :slots (getf view-def :slots) - :source-code (getf view-def :source-code))) + :object-class (class-name cl) + :id (getf view-def :id) + :slots (getf view-def :slots) + :source-code (getf view-def :source-code))) (t (error "Invalid parameter to make-object-view: ~S" view-def)))) (defmethod initialize-instance :after ((self object-view) - &rest initargs - &key - &allow-other-keys) + &rest initargs + &key + &allow-other-keys) + (declare (ignore initargs)) (initialize-view self)) - + (defun initialize-view (view) "Calculate all view slots for a hyperobject class" (let ((obj-cl (find-class (object-class view)))) @@ -182,21 +183,21 @@ (defun initialize-view-by-source-code (view) "Initialize a view based upon a source code" (let* ((source-code (source-code view)) - (printer `(lambda - (,(intern (symbol-name '#:self) - (symbol-package (object-class view))) - ,(intern (symbol-name '#:s) - (symbol-package (object-class view)))) - (declare (ignorable - ,(intern (symbol-name '#:self) - (symbol-package (object-class view))) - ,(intern (symbol-name '#:s) - (symbol-package (object-class view))))) - (with-slots ,(slots view) - ,(intern (symbol-name '#:self) - (symbol-package (object-class view))) - ,@source-code)))) - (setf (printer view) + (printer `(lambda + (,(intern (symbol-name '#:self) + (symbol-package (object-class view))) + ,(intern (symbol-name '#:s) + (symbol-package (object-class view)))) + (declare (ignorable + ,(intern (symbol-name '#:self) + (symbol-package (object-class view))) + ,(intern (symbol-name '#:s) + (symbol-package (object-class view))))) + (with-slots ,(slots view) + ,(intern (symbol-name '#:self) + (symbol-package (object-class view))) + ,@source-code)))) + (setf (printer view) (compile nil (eval printer))))) (defmacro write-simple (v s) @@ -213,12 +214,12 @@ (defun write-ho-value (obj name type formatter cdata strm) (declare (ignorable type)) (let* ((slot-data (slot-value obj name)) - (fmt-data (if formatter - (funcall formatter slot-data) - slot-data))) + (fmt-data (if formatter + (funcall formatter slot-data) + slot-data))) (if cdata - (write-cdata fmt-data strm) - (write-simple fmt-data strm)))) + (write-cdata fmt-data strm) + (write-simple fmt-data strm)))) (defun ppfc-html (title name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) (ppfc-html title name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func)) - + (defun ppfc-html-labels (label name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) - (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-html label name type formatter cdata print-func)) (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func) (vector-push-extend '(write-string "" s) print-func) - (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-html tag name type formatter cdata print-func)) (defun ppfc-xml-labels (label tag name type formatter cdata print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-xml tag name type formatter cdata print-func)) (defun ppfc-html-link (name type formatter cdata nlink print-func) (declare (fixnum nlink)) (vector-push-extend '(write-char #\< s) print-func) - (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func) + (vector-push-extend `(when (stringp (nth ,(+ nlink nlink) links)) + (write-string (nth ,(+ nlink nlink) links) s)) print-func) (vector-push-extend '(write-char #\> s) print-func) (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) (vector-push-extend '(write-string " s) print-func)) (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func) (vector-push-extend '(write-string "" s) print-func) - (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func) (vector-push-extend '(write-string " " s) print-func) (ppfc-html-link name type formatter cdata nlink print-func)) (defun push-print-fun-code (vid slot nlink print-func) (let* ((formatter (esd-print-formatter slot)) - (name (slot-definition-name slot)) - (user-name (esd-user-name slot)) - (xml-user-name (escape-xml-string user-name)) - (xml-tag (escape-xml-string user-name)) - (type (slot-value slot 'type)) - (cdata (not (null - (and (in vid :xml :xhtml :xml-link :xhtml-link - :xml-labels :ie-xml-labels - :xhtml-link-labels :xml-link-labels :ie-xml-link - :ie-xml-link-labels) - (or formatter - (lisp-type-is-a-string type)))))) - (hyperlink (esd-hyperlink slot))) - + (name (slot-definition-name slot)) + (user-name (esd-user-name slot)) + (xml-user-name (escape-xml-string user-name)) + (xml-tag (escape-xml-string user-name)) + (value-type (slot-value slot 'value-type)) + (cdata (and (in vid :xml :xhtml :xml-link :xhtml-link + :xml-labels :ie-xml-labels + :xhtml-link-labels :xml-link-labels :ie-xml-link + :ie-xml-link-labels) + (or formatter + (value-type-is-a-string value-type)) + t)) + (hyperlink (esd-hyperlink slot))) + (case vid (:compact-text (vector-push-extend - `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) + `(write-ho-value x ',name ',value-type ',formatter ,cdata s) print-func)) (:compact-text-labels (vector-push-extend `(write-string ,user-name s) print-func) (vector-push-extend '(write-char #\space s) print-func) (vector-push-extend - `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) + `(write-ho-value x ',name ',value-type ',formatter ,cdata s) print-func)) ((or :html :xhtml) - (ppfc-html user-name name type formatter cdata print-func)) + (ppfc-html user-name name value-type formatter cdata print-func)) (:xml - (ppfc-xml xml-tag name type formatter cdata print-func)) + (ppfc-xml xml-tag name value-type formatter cdata print-func)) (:html-labels - (ppfc-html-labels user-name name type formatter cdata print-func)) + (ppfc-html-labels user-name name value-type formatter cdata print-func)) (:xhtml-labels - (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func)) + (ppfc-xhtml-labels xml-user-name user-name name value-type formatter cdata print-func)) ((:display-table :display-table-labels) - (ppfc-display-table user-name name type formatter cdata print-func)) + (ppfc-display-table user-name name value-type formatter cdata print-func)) (:xml-labels - (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func)) + (ppfc-xml-labels xml-user-name xml-tag name value-type formatter cdata print-func)) ((or :html-link :xhtml-link) (if hyperlink - (ppfc-html-link name type formatter cdata nlink print-func) - (ppfc-html user-name name type formatter cdata print-func))) + (ppfc-html-link name value-type formatter cdata nlink print-func) + (ppfc-html user-name name value-type formatter cdata print-func))) ((or :xml-link :ie-xml-link) (if hyperlink - (ppfc-html-link name type formatter cdata nlink print-func) - (ppfc-xml xml-tag name type formatter cdata print-func))) + (ppfc-html-link name value-type formatter cdata nlink print-func) + (ppfc-xml xml-tag name value-type formatter cdata print-func))) (:html-link-labels (if hyperlink - (ppfc-html-link-labels user-name name type formatter cdata nlink - print-func) - (ppfc-html-labels user-name name type formatter cdata print-func))) + (ppfc-html-link-labels user-name name value-type formatter cdata nlink + print-func) + (ppfc-html-labels user-name name value-type formatter cdata print-func))) (:xhtml-link-labels (if hyperlink - (ppfc-html-link-labels xml-user-name name type formatter cdata nlink - print-func) - (ppfc-xhtml-labels xml-tag user-name name type formatter cdata - print-func))) + (ppfc-html-link-labels xml-user-name name value-type formatter cdata nlink + print-func) + (ppfc-xhtml-labels xml-tag user-name name value-type formatter cdata + print-func))) ((or :xml-link-labels :ie-xml-link-labels) (if hyperlink - (ppfc-html-link-labels xml-user-name name type formatter cdata nlink - print-func) - (ppfc-xml-labels xml-tag user-name name type formatter cdata - print-func)))))) + (ppfc-html-link-labels xml-user-name name value-type formatter cdata nlink + print-func) + (ppfc-xml-labels xml-tag user-name name value-type formatter cdata + print-func)))))) (defun view-has-links-p (view) @@ -359,34 +362,34 @@ "Initialize a view based upon a preset vid" (unless (creatable-view-id-p obj-cl (id view)) (error "Unable to automatically create view id ~A" (id view))) - + (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) (let ((links '()) - (print-func (make-array 20 :fill-pointer 0 :adjustable t))) + (print-func (make-array 20 :fill-pointer 0 :adjustable t))) (do* ((slots (slots view) (cdr slots)) - (slot-name (car slots) (car slots)) - (slot (find-slot-by-name obj-cl slot-name) - (find-slot-by-name obj-cl slot-name))) - ((null slots)) + (slot-name (car slots) (car slots)) + (slot (find-slot-by-name obj-cl slot-name) + (find-slot-by-name obj-cl slot-name))) + ((null slots)) (unless slot - (error "Slot ~A is not found in class ~S" slot-name obj-cl)) - + (error "Slot ~A is not found in class ~S" slot-name obj-cl)) + (push-print-fun-code (id view) slot (length links) print-func) (when (> (length slots) 1) - (vector-push-extend '(write-char #\space s) print-func)) + (vector-push-extend '(write-char #\space s) print-func)) (when (and (view-has-links-p view) (esd-hyperlink slot)) - (push (slot-definition-name slot) links))) + (push (slot-definition-name slot) links))) (vector-push-extend 'x print-func) ;; return object (setf (obj-data-print-code view) `(lambda (x s links) - (declare (ignorable s links)) - ,@(map 'list #'identity print-func))) + (declare (ignorable s links)) + ,@(map 'list #'identity print-func))) (setf (obj-data-printer view) - (compile nil (eval (obj-data-print-code view)))) - + (compile nil (eval (obj-data-print-code view)))) + (setf (link-slots view) (nreverse links))) (finalize-view-by-id view) @@ -422,7 +425,7 @@ ((or :xml-link :xml-link-labels) (initialize-xml-view view) (setf (link-href-start view) - "xmllink xlink:type=\"simple\" xlink:href=") + "xmllink xlink:type=\"simple\" xlink:href=") (setf (link-href-end view) "xmllink") (setf (link-ampersand view) "&")) ((or :ie-xml-link :ie-xml-link-labels) @@ -450,12 +453,12 @@ (defun initialize-text-view (view) (setf (list-start-printer view) - (compile nil - (eval '(lambda (obj nitems indent strm) - (declare (ignore indent)) - (write-user-name-maybe-plural obj nitems strm) - (write-char #\: strm) - (write-char #\Newline strm))))) + (compile nil + (eval '(lambda (obj nitems indent strm) + (declare (ignore indent)) + (write-user-name-maybe-plural obj nitems strm) + (write-char #\: strm) + (write-char #\Newline strm))))) (setf (list-start-indent view) t) (setf (obj-data-indent view) t) (setf (obj-data-end-printer view) +newline-string+) @@ -582,7 +585,7 @@ (defun initialize-xml-view (view) (let ((name (string-downcase (symbol-name (object-class view))))) - (setf (file-start-str view) "") ; (std-xml-header) + (setf (file-start-str view) "") ; (std-xml-header) (setf (list-start-indent view) t) (setf (list-start-printer view) #'xmlformat-list-start-func) (setf (list-end-indent view) t) @@ -590,7 +593,8 @@ (setf (obj-start-printer view) (format nil "<~(~a~)>" name)) (setf (obj-start-indent view) t) (setf (obj-end-printer view) (format nil "~%" name)) - (setf (subobj-end-printer view) (format nil "~%" name)) +;; (setf (subobj-end-printer view) (format nil "~%" name)) + (setf (subobj-end-printer view) nil) (setf (subobj-end-indent view) nil) (setf (obj-data-indent view) nil))) @@ -599,32 +603,32 @@ (defun fmt-file-start (view strm) (awhen (file-start-str view) - (write-string it strm))) + (write-string it strm))) (defun fmt-file-end (view strm) (awhen (file-end-str view) - (write-string it strm))) + (write-string it strm))) ;;; List Start and Ends (defun fmt-list-start (obj view strm indent num-items) (when (list-start-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (list-start-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj num-items indent strm)))) + (if (stringp it) + (write-string it strm) + (funcall it obj num-items indent strm)))) (defun fmt-list-end (obj view strm indent num-items) (declare (ignore num-items)) (when (list-end-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (list-end-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj strm)))) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) ;;; Object Start and Ends @@ -632,40 +636,40 @@ (defun fmt-obj-start (obj view strm indent) (when (obj-start-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (obj-start-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj indent strm)))) + (if (stringp it) + (write-string it strm) + (funcall it obj indent strm)))) (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (obj-end-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj strm)))) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) (defun fmt-subobj-start (obj view strm indent) (when (subobj-start-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (subobj-start-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj indent strm)))) + (if (stringp it) + (write-string it strm) + (funcall it obj indent strm)))) (defun fmt-subobj-end (obj view strm indent) (when (subobj-end-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (awhen (subobj-end-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj strm)))) - -;;; Object Data + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) + +;;; Object Data (defun make-link-start (view fieldfunc fieldvalue refvars link-printer) @@ -674,45 +678,45 @@ (write-char #\" s) (let ((link-page (link-page view))) (cond - ((null link-printer) - (write-string (make-url link-page) s) - (write-string "?func=" s) - (write-simple fieldfunc s) - (write-string (link-ampersand view) s) - (write-string "key=" s) - (write-simple fieldvalue s) - (dolist (var refvars) - (write-string (link-ampersand view) s) - (write-simple (car var) s) - (write-char #\= s) - (write-simple (cdr var) s))) - (link-printer - (funcall link-printer link-page fieldfunc fieldvalue refvars s)))) + ((null link-printer) + (write-string (make-url link-page) s) + (write-string "?func=" s) + (write-simple fieldfunc s) + (write-string (link-ampersand view) s) + (write-string "key=" s) + (write-simple fieldvalue s) + (dolist (var refvars) + (write-string (link-ampersand view) s) + (write-simple (car var) s) + (write-char #\= s) + (write-simple (cdr var) s))) + (link-printer + (funcall link-printer link-page fieldfunc fieldvalue refvars s)))) (write-char #\" s))) - + (defun make-link-end (obj view fieldname) (declare (ignore obj fieldname)) (link-href-end view)) (defun fmt-obj-data (obj view strm indent refvars link-printer) (awhen (obj-data-start-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj strm))) + (if (stringp it) + (write-string it strm) + (funcall it obj strm))) (when (obj-data-indent view) (awhen (indenter view) - (funcall it indent strm))) + (funcall it indent strm))) (if (link-slots view) (fmt-obj-data-with-link obj view strm refvars link-printer) (fmt-obj-data-plain obj view strm)) (awhen (obj-data-end-printer view) - (if (stringp it) - (write-string it strm) - (funcall it obj strm)))) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) (defun fmt-obj-data-plain (obj view strm) (awhen (obj-data-printer view) - (funcall it obj strm nil))) + (funcall it obj strm nil))) (defun fmt-obj-data-with-link (obj view strm refvars link-printer) (let ((refvalues '())) @@ -720,11 +724,11 @@ ;; make list of hyperlink link fields for printing to refstr template (dolist (name (link-slots view)) (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name) - (push (make-link-start view (lookup it) (slot-value obj name) - (append (link-parameters it) refvars) - link-printer) - refvalues) - (push (make-link-end obj view name) refvalues))) + (push (make-link-start view (lookup it) (slot-value obj name) + (append (link-parameters it) refvars) + link-printer) + refvalues) + (push (make-link-end obj view name) refvalues))) (funcall (obj-data-printer view) obj strm (nreverse refvalues)))) (defun obj-data (obj view) @@ -739,52 +743,52 @@ (dolist (obj (mklist objs)) (dolist (subobj (hyperobject-class-subobjects obj)) (awhen (slot-value obj (name-slot subobj)) - (load-all-subobjects it)))) + (load-all-subobjects it)))) objs) (defun view-subobjects (obj strm &optional vid (indent 0) filter - subobjects refvars link-printer) + subobjects refvars link-printer) (when (hyperobject-class-subobjects obj) (dolist (subobj (hyperobject-class-subobjects obj)) (aif (slot-value obj (name-slot subobj)) - (view-hyperobject - it (get-view-id (car (mklist it)) vid) - strm vid (1+ indent) filter subobjects refvars - link-printer))))) + (view-hyperobject + it (get-view-id (car (mklist it)) vid) + strm vid (1+ indent) filter subobjects refvars + link-printer))))) + - (defun view-hyperobject (objs view strm &optional vid (indent 0) filter - subobjects refvars link-printer) + subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" (let-when (objlist (mklist objs)) (let ((nobjs (length objlist)) - (*print-pretty* nil) - (*print-circle* nil) - (*print-escape* nil) - (*print-readably* nil) - (*print-length* nil) - (*print-level* nil)) + (*print-pretty* nil) + (*print-circle* nil) + (*print-escape* nil) + (*print-readably* nil) + (*print-length* nil) + (*print-level* nil)) (fmt-list-start (car objlist) view strm indent nobjs) (dolist (obj objlist) - (awhen (printer view) - (funcall it obj strm)) - (unless (and filter (not (funcall filter obj))) - (fmt-obj-start obj view strm indent) - (fmt-obj-data obj view strm (1+ indent) refvars link-printer) - (fmt-obj-end obj view strm indent) - (if subobjects - (progn - (fmt-subobj-start obj view strm indent) - (view-subobjects obj strm vid indent filter subobjects - refvars link-printer) - (fmt-subobj-end obj view strm indent)) - (fmt-subobj-start obj view strm indent)))) + (awhen (printer view) + (funcall it obj strm)) + (unless (and filter (not (funcall filter obj))) + (fmt-obj-start obj view strm indent) + (fmt-obj-data obj view strm (1+ indent) refvars link-printer) + (fmt-obj-end obj view strm indent) + (if subobjects + (progn + (fmt-subobj-start obj view strm indent) + (view-subobjects obj strm vid indent filter subobjects + refvars link-printer) + (fmt-subobj-end obj view strm indent)) + (fmt-subobj-start obj view strm indent)))) (fmt-list-end (car objlist) view strm indent nobjs))) objs) (defun view (objs &key (stream *standard-output*) vid view - filter subobjects refvars file-wrapper link-printer) + filter subobjects refvars file-wrapper link-printer) "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject" (let-when (objlist (mklist objs)) (unless view @@ -792,7 +796,7 @@ (when file-wrapper (fmt-file-start view stream)) (view-hyperobject objlist view stream vid 0 filter subobjects refvars - link-printer) + link-printer) (when file-wrapper (fmt-file-end view stream))) objs)