1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: View methods for Hyperobjects
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Apr 2000
10 ;;;; $Id: views.lisp,v 1.59 2003/06/29 16:21:09 kevin Exp $
12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
15 (in-package #:hyperobject)
18 (defclass object-view ()
19 ((object-class-name :initform nil :initarg :object-class-name
20 :accessor object-class-name
21 :documentation "Name of class of object to be viewed.")
22 (object-class :initform nil :initarg :object-class
23 :accessor object-class
24 :documentation "Class of object to be viewed.")
25 (slots :initform nil :initarg :slots :accessor slots
26 :documentation "List of effective slots for object to be viewed.")
27 (name :initform nil :initarg :name :accessor name
28 :documentation "Name for this view.")
29 (category :initform nil :initarg :category :accessor category
30 :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.")
31 (source-code :initform nil :initarg :source-code :accessor source-code
32 :documentation "Source code for generating view.")
33 (country-language :initform :en :initarg :country-language
34 :documentation "Country's Language for this view.")
36 (file-start-str :type (or string null) :initform nil :initarg :file-start-str
37 :accessor file-start-str)
38 (file-end-str :type (or string null) :initform nil :initarg :file-end-str
39 :accessor file-end-str)
40 (list-start-printer :type (or string function null) :initform nil
41 :initarg :list-start-printer
42 :accessor list-start-printer)
43 (list-start-indent :initform nil :initarg :list-start-indent
44 :accessor list-start-indent)
45 (list-end-printer :type (or string function null) :initform nil
46 :initarg :list-end-printer
47 :accessor list-end-printer)
48 (list-end-indent :initform nil :initarg :list-end-indent
49 :accessor list-end-indent)
50 (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer
51 :accessor obj-start-printer)
52 (obj-start-indent :initform nil :initarg :obj-start-indent
53 :accessor obj-start-indent)
54 (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer
55 :accessor obj-end-printer)
56 (obj-end-indent :initform nil :initarg :obj-end-indent
57 :accessor obj-end-indent)
58 (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer
59 :accessor subobj-start-printer)
60 (subobj-start-indent :initform nil :initarg :subobj-start-indent
61 :accessor subobj-start-indent)
62 (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer
63 :accessor subobj-end-printer)
64 (subobj-end-indent :initform nil :initarg :subobj-end-indent
65 :accessor subobj-end-indent)
66 (obj-data-indent :initform nil :initarg :obj-data-indent
67 :accessor obj-data-indent)
68 (obj-data-printer :type (or function null) :initform nil
69 :initarg :obj-data-printer
70 :accessor obj-data-printer)
71 (obj-data-print-code :type (or function null) :initform nil
72 :initarg :obj-data-print-code
73 :accessor obj-data-print-code)
74 (obj-data-start-printer :type (or function string null) :initform nil
75 :initarg :obj-data-start-printer
76 :accessor obj-data-start-printer)
77 (obj-data-end-printer :type (or string null) :initform nil
78 :initarg :obj-data-end-printer
79 :accessor obj-data-end-printer)
80 (indenter :type (or function null) :initform nil
82 :documentation "Function that performs hierarchical indenting")
83 (link-slots :type list :initform nil
84 :documentation "List of slot names that have hyperlinks"
86 (link-page :type (or string null) :initform nil
89 (link-href-start :type (or string null) :initform nil :initarg :link-href-start
90 :accessor link-href-start)
91 (link-href-end :type (or string null) :initform nil :initarg :link-href-end
92 :accessor link-href-end)
93 (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
94 :accessor link-ampersand))
95 (:default-initargs :link-page "lookup-func1")
96 (:documentation "View class for a hyperobject"))
99 (defun get-category-view (obj category &optional slots)
100 "Find or make a category view for an object"
101 (let ((obj-class (class-of obj)))
103 (default-view obj-class)
104 (aif (find category (views obj-class) :key #'category)
107 (make-instance 'object-view
108 :object-class-name (class-name obj-class)
109 :object-class obj-class
112 (push view (views obj-class))
115 ;;;; *************************************************************************
116 ;;;; Metaclass Intialization
117 ;;;; *************************************************************************
119 (defun finalize-views (cl)
120 "Finalize all views that are given on a objects initialization"
121 (unless (default-print-slots cl)
122 (setf (default-print-slots cl)
123 (mapcar #'slot-definition-name (class-slots cl))))
125 (dolist (view-def (views cl))
126 (push (make-object-view cl view-def) views))
127 (setf (views cl) (nreverse views)))
130 (setf (default-view cl) (make-object-view cl (default-view cl))))
132 (setf (default-view cl) (make-object-view cl (car (views cl)))))
134 (setf (default-view cl) (make-object-view cl :default)))))
136 (defun make-object-view (cl view-def)
137 "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
139 ((typep view-def 'object-view)
141 ((eq view-def :default)
142 (let* ((name (class-name cl))
143 (view (make-instance 'object-view :name "automatic"
144 :object-class-name name
146 :category :compact-text)))
149 (apply #'make-instance 'object-view view-def))
151 (error "Invalid parameter to make-object-view: ~S" view-def))))
153 (defmethod initialize-instance :after ((view object-view)
154 &rest initargs &key &allow-other-keys)
155 (initialize-view (object-class view) view))
157 (defun initialize-view (obj-cl view)
158 "Calculate all view slots for a hyperobject class"
161 (initialize-view-by-category obj-cl view))
163 (initialize-view-by-source-code obj-cl view))
165 (setf (category view) :compact-text)
166 (initialize-view-by-category obj-cl view))))
168 (defun initialize-view-by-source-code (obj-cl view)
169 "Initialize a view based upon a source code"
170 (let ((source-code (source-code view)))
171 (warn "source code compilation is not implemented")
175 (defmacro write-simple (v s)
178 (write-string ,v ,s))
180 (write-fixnum ,v ,s))
182 (write-string (symbol-name ,v) ,s))
184 (write-string (write-to-string ,v) ,s))))
186 (defun write-ho-value (obj name type formatter cdata strm)
187 (declare (ignorable type))
188 (let* ((slot-data (slot-value obj name))
189 (fmt-data (if formatter
190 (funcall formatter slot-data)
193 (write-xml-cdata fmt-data strm)
194 (write-simple fmt-data strm))))
196 (defun ppfc-html (title name type formatter cdata print-func)
197 (vector-push-extend '(write-string "<span class=\"" s) print-func)
198 (vector-push-extend `(write-string ,title s) print-func)
199 (vector-push-extend '(write-string "\">" s) print-func)
200 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
201 (vector-push-extend '(write-string "</span>" s) print-func))
203 (defun ppfc-xml (tag name type formatter cdata print-func)
204 (vector-push-extend '(write-char #\< s) print-func)
205 (vector-push-extend `(write-string ,tag s) print-func)
206 (vector-push-extend '(write-char #\> s) print-func)
207 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
208 (vector-push-extend '(write-string "</" s) print-func)
209 (vector-push-extend `(write-string ,tag s) print-func)
210 (vector-push-extend '(write-char #\> s) print-func))
212 (defun ppfc-html-labels (label name type formatter cdata print-func)
213 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
214 (vector-push-extend `(write-string ,label s) print-func)
215 (vector-push-extend '(write-string "</span> " s) print-func)
216 (ppfc-html label name type formatter cdata print-func))
218 (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
219 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
220 (vector-push-extend `(write-string ,label s) print-func)
221 (vector-push-extend '(write-string "</span> " s) print-func)
222 (ppfc-html tag name type formatter cdata print-func))
224 (defun ppfc-xml-labels (label tag name type formatter cdata print-func)
225 (vector-push-extend '(write-string "<label>" s) print-func)
226 (vector-push-extend `(write-string ,label s) print-func)
227 (vector-push-extend '(write-string "</label> " s) print-func)
228 (ppfc-xml tag name type formatter cdata print-func))
230 (defun ppfc-html-link (name type formatter cdata nlink print-func)
231 (declare (fixnum nlink))
232 (vector-push-extend '(write-char #\< s) print-func)
233 (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)
234 (vector-push-extend '(write-char #\> s) print-func)
235 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
236 (vector-push-extend '(write-string "</" s) print-func)
237 (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)
238 (vector-push-extend '(write-char #\> s) print-func))
240 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
241 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
242 (vector-push-extend `(write-string ,label s) print-func)
243 (vector-push-extend '(write-string "</span> " s) print-func)
244 (ppfc-html-link name type formatter cdata nlink print-func))
246 (defun push-print-fun-code (category slot nlink print-func)
247 (let* ((formatter (esd-print-formatter slot))
248 (name (slot-definition-name slot))
249 (user-name (esd-user-name slot))
250 (xml-user-name (escape-xml-string user-name))
251 (xml-tag (escape-xml-string user-name))
252 (type (slot-value slot 'type))
254 (and (in category :xml :xhtml :xml-link :xhtml-link
255 :xml-labels :ie-xml-labels
256 :xhtml-link-labels :xml-link-labels :ie-xml-link
259 (lisp-type-is-a-string type))))))
260 (hyperlink (esd-hyperlink slot)))
265 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
266 (:compact-text-labels
267 (vector-push-extend `(write-string ,user-name s) print-func)
268 (vector-push-extend '(write-char #\space s) print-func)
270 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
272 (ppfc-html user-name name type formatter cdata print-func))
274 (ppfc-xml xml-tag name type formatter cdata print-func))
276 (ppfc-html-labels user-name name type formatter cdata print-func))
278 (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
280 (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
281 ((or :html-link :xhtml-link)
283 (ppfc-html-link name type formatter cdata nlink print-func)
284 (ppfc-html user-name name type formatter cdata print-func)))
285 ((or :xml-link :ie-xml-link)
287 (ppfc-html-link name type formatter cdata nlink print-func)
288 (ppfc-xml xml-tag name type formatter cdata print-func)))
291 (ppfc-html-link-labels user-name name type formatter cdata nlink
293 (ppfc-html-labels user-name name type formatter cdata print-func)))
296 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
298 (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
300 ((or :xml-link-labels :ie-xml-link-labels)
302 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
304 (ppfc-xml-labels xml-tag user-name name type formatter cdata
308 (defun view-has-links-p (view)
309 (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link
310 :html-link-labels :xhtml-link-labels :xml-link-labels
311 :ie-xml-link-labels))
313 (defun initialize-view-by-category (obj-cl view)
314 "Initialize a view based upon a preset category"
315 (unless (in (category view) :compact-text :compact-text-labels
316 :html :html-labels :html-link-labels
317 :xhtml :xhtml-labels :xhtml-link-labels
318 :xhtml-link :html-link
319 :xml :xml-labels :xml-link :ie-xml-link
320 :xml-link-labels :ie-xml-link-labels
321 :display-table :edit-table)
322 (error "Unknown view category ~A" (category view)))
324 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
327 (print-func (make-array 10 :fill-pointer 0 :adjustable t)))
329 (do* ((slots (slots view) (cdr slots))
330 (slot-name (car slots) (car slots))
331 (slot (find-slot-by-name obj-cl slot-name)
332 (find-slot-by-name obj-cl slot-name)))
335 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
337 (push-print-fun-code (category view) slot (length links) print-func)
338 (when (> (length slots) 1)
339 (vector-push-extend '(write-char #\space s) print-func))
341 (when (and (view-has-links-p view) (esd-hyperlink slot))
342 (push (slot-definition-name slot) links)))
344 (vector-push-extend 'x print-func) ;; return object
345 (setf (obj-data-print-code view) `(lambda (x s links)
346 (declare (ignorable s links))
347 ,@(map 'list #'identity print-func)))
348 (setf (obj-data-printer view)
349 (compile nil (eval (obj-data-print-code view))))
351 (setf (link-slots view) (nreverse links)))
353 (finalize-view-by-category view)
356 (defun finalize-view-by-category (view)
357 (case (category view)
358 ((or :compact-text :compact-text-labels)
359 (initialize-text-view view))
360 ((or :html :html-labels)
361 (initialize-html-view view))
362 ((or :xhtml :xhtml-labels)
363 (initialize-xhtml-view view))
364 ((or :xml :xml-labels)
365 (initialize-xml-view view))
366 ((or :html-link :html-link-labels)
367 (initialize-html-view view)
368 (setf (link-href-start view) "a href=")
369 (setf (link-href-end view) "a")
370 (setf (link-ampersand view) "&"))
371 ((or :xhtml-link :xhtml-link-labels)
372 (initialize-xhtml-view view)
373 (setf (link-href-start view) "a href=")
374 (setf (link-href-end view) "a")
375 (setf (link-ampersand view) "&"))
376 ((or :xml-link :xml-link-labels)
377 (initialize-xml-view view)
378 (setf (link-href-start view)
379 "xmllink xlink:type=\"simple\" xlink:href=")
380 (setf (link-href-end view) "xmllink")
381 (setf (link-ampersand view) "&"))
382 ((or :ie-xml-link :ie-xml-link-labels)
383 (initialize-xml-view view)
384 (setf (link-href-start view) "html:a href=")
385 (setf (link-href-end view) "html:a")
386 (setf (link-ampersand view) "&"))))
389 (defun make-std-object-slots-view (class-name slots)
395 ;;;; *************************************************************************
396 ;;;; View Data Format Section
397 ;;;; *************************************************************************
399 (defun class-name-of (obj)
400 (string-downcase (class-name (class-of obj))))
402 (defvar +newline-string+ (format nil "~%"))
404 (defun write-user-name-maybe-plural (obj nitems strm)
407 (hyperobject-class-user-name-plural obj)
408 (hyperobject-class-user-name obj))
411 (defun initialize-text-view (view)
412 (setf (list-start-printer view)
414 (eval '(lambda (obj nitems indent strm)
415 (declare (ignore indent))
416 (write-user-name-maybe-plural obj nitems strm)
417 (write-char #\: strm)
418 (write-char #\Newline strm)))))
419 (setf (list-start-indent view) t)
420 (setf (obj-data-indent view) t)
421 (setf (obj-data-end-printer view) +newline-string+)
422 (setf (indenter view) #'indent-spaces))
424 (defun html-list-start-func (obj nitems indent strm)
425 (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
426 (write-fixnum (+ indent indent) strm)
427 (write-string "em;\">" strm)
428 (write-user-name-maybe-plural obj nitems strm)
429 (write-string "</div>" strm)
430 (write-char #\newline strm)
431 (write-string "<ul>" strm)
432 (write-char #\newline strm))
434 (defun initialize-html-view (view)
435 (initialize-text-view view)
436 (setf (indenter view) #'indent-spaces)
437 (setf (file-start-str view) (format nil "<html><body>~%"))
438 (setf (file-end-str view) (format nil "</body><html>~%"))
439 (setf (list-start-indent view) t)
440 (setf (list-start-printer view) #'html-list-start-func)
441 (setf (list-end-printer view) (format nil "</ul>~%"))
442 (setf (list-end-indent view) t)
443 (setf (obj-start-indent view) nil)
444 (setf (obj-start-printer view) "<li>")
445 (setf (obj-end-indent view) nil)
446 (setf (obj-end-printer view) (format nil "</li>~%"))
447 (setf (obj-data-end-printer view) nil)
448 (setf (obj-data-indent view) nil))
450 (defun xhtml-list-start-func (obj nitems indent strm)
451 (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
452 (write-fixnum (+ indent indent) strm)
453 (write-string "em;\">" strm)
454 (write-user-name-maybe-plural obj nitems strm)
455 (write-string "</div>" strm)
456 (write-string "<div :style=\"margin-left:" strm)
457 (write-fixnum (+ indent indent) strm)
458 (write-string "em;\">" strm)
459 (write-char #\newline strm))
461 (defun html-obj-start (obj indent strm)
462 (declare (ignore obj indent))
463 (write-string "<div style=\"margin-left:2em;\">" strm))
465 (defun initialize-xhtml-view (view)
466 (initialize-text-view view)
467 (setf (indenter view) #'indent-spaces)
468 (setf (file-start-str view) (format nil "<html><body>~%"))
469 (setf (file-end-str view) (format nil "</body><html>~%"))
470 (setf (list-start-indent view) nil)
471 (setf (list-start-printer view) #'xhtml-list-start-func)
472 (setf (list-end-printer view) (format nil "</div>~%"))
473 (setf (list-end-indent view) nil)
474 (setf (obj-start-indent view) nil)
475 (setf (obj-start-printer view) #'html-obj-start)
476 (setf (obj-end-printer view) (format nil "</div>~%"))
477 (setf (obj-data-indent view) nil))
479 (defun xmlformat-list-end-func (x strm)
480 (write-string "</" strm)
481 (write-string (class-name-of x) strm)
482 (write-string "list" strm)
483 (write-string ">" strm)
484 (write-char #\newline strm))
486 (defun xmlformat-list-start-func (x nitems indent strm)
487 (declare (ignore indent))
488 (write-char #\< strm)
489 (write-string (class-name-of x) strm)
490 (write-string "list><title>" strm)
491 (write-user-name-maybe-plural x nitems strm)
492 (write-string ":</title>" strm)
493 (write-char #\newline strm))
495 (defun initialize-xml-view (view)
496 (setf (file-start-str view) "") ; (std-xml-header)
497 (setf (list-start-indent view) t)
498 (setf (list-start-printer view) #'xmlformat-list-start-func)
499 (setf (list-end-indent view) t)
500 (setf (list-end-printer view) #'xmlformat-list-end-func)
501 (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view)))
502 (setf (obj-start-indent view) t)
503 (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" (object-class-name view)))
504 (setf (subobj-end-indent view) nil)
505 (setf (obj-data-indent view) nil))
508 ;;; File Start and Ends
510 (defun fmt-file-start (view strm)
511 (awhen (file-start-str view)
512 (write-string it strm)))
514 (defun fmt-file-end (view strm)
515 (awhen (file-end-str view)
516 (write-string it strm)))
518 ;;; List Start and Ends
520 (defun fmt-list-start (obj view strm indent num-items)
521 (when (list-start-indent view)
522 (awhen (indenter view)
523 (funcall it indent strm)))
524 (awhen (list-start-printer view)
526 (write-string it strm)
527 (funcall it obj num-items indent strm))))
529 (defun fmt-list-end (obj view strm indent num-items)
530 (declare (ignore num-items))
531 (when (list-end-indent view)
532 (awhen (indenter view)
533 (funcall it indent strm)))
534 (awhen (list-end-printer view)
536 (write-string it strm)
537 (funcall it obj strm))))
539 ;;; Object Start and Ends
542 (defun fmt-obj-start (obj view strm indent)
543 (when (obj-start-indent view)
544 (awhen (indenter view)
545 (funcall it indent strm)))
546 (awhen (obj-start-printer view)
548 (write-string it strm)
549 (funcall it obj indent strm))))
551 (defun fmt-obj-end (obj view strm indent)
552 (when (obj-end-indent view)
553 (awhen (indenter view)
554 (funcall it indent strm)))
555 (awhen (obj-end-printer view)
557 (write-string it strm)
558 (funcall it obj strm))))
560 (defun fmt-subobj-start (obj view strm indent)
561 (when (subobj-start-indent view)
562 (awhen (indenter view)
563 (funcall it indent strm)))
564 (awhen (subobj-start-printer view)
566 (write-string it strm)
567 (funcall it obj indent strm))))
569 (defun fmt-subobj-end (obj view strm indent)
570 (when (subobj-end-indent view)
571 (awhen (indenter view)
572 (funcall it indent strm)))
573 (awhen (subobj-end-printer view)
575 (write-string it strm)
576 (funcall it obj strm))))
581 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
582 (with-output-to-string (s)
583 (write-string (link-href-start view) s)
585 (let ((link-page (link-page view)))
588 (write-string (make-url link-page) s)
589 (write-string "?func=" s)
590 (write-simple fieldfunc s)
591 (write-string (link-ampersand view) s)
592 (write-string "key=" s)
593 (write-simple fieldvalue s)
594 (dolist (var refvars)
595 (write-string (link-ampersand view) s)
596 (write-simple (car var) s)
598 (write-simple (cdr var) s)))
600 (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
603 (defun make-link-end (obj view fieldname)
604 (declare (ignore obj fieldname))
605 (link-href-end view))
607 (defun fmt-obj-data (obj view strm indent refvars link-printer)
608 (awhen (obj-data-start-printer view)
610 (write-string it strm)
611 (funcall it obj strm)))
612 (when (obj-data-indent view)
613 (awhen (indenter view)
614 (funcall it indent strm)))
615 (if (link-slots view)
616 (fmt-obj-data-with-link obj view strm refvars link-printer)
617 (fmt-obj-data-plain obj view strm))
618 (awhen (obj-data-end-printer view)
620 (write-string it strm)
621 (funcall it obj strm))))
623 (defun fmt-obj-data-plain (obj view strm)
624 (awhen (obj-data-printer view)
625 (funcall it obj strm nil)))
627 (defun fmt-obj-data-with-link (obj view strm refvars link-printer)
628 (let ((refvalues '()))
629 (declare (dynamic-extent refvalues))
630 ;; make list of hyperlink link fields for printing to refstr template
631 (dolist (name (link-slots view))
632 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
633 (push (make-link-start view (lookup it) (slot-value obj name)
634 (append (link-parameters it) refvars)
637 (push (make-link-end obj view name) refvalues)))
638 (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
640 (defun obj-data (obj view)
641 "Returns the objects data as a string. Used by common-graphics outline function"
642 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
644 ;;; Display method for objects
647 (defun load-all-subobjects (objs)
648 "Load all subobjects if they have not already been loaded."
649 (dolist (obj (mklist objs))
650 (dolist (subobj (hyperobject-class-subobjects obj))
651 (awhen (slot-value obj (name-slot subobj))
652 (load-all-subobjects it))))
655 (defun view-hyperobject (objs view category strm &optional (indent 0) filter
656 subobjects refvars link-printer)
657 "Display a single or list of hyperobject-class instances and their subobjects"
658 (let-when (objlist (mklist objs))
659 (let ((nobjs (length objlist))
663 (*print-readably* nil)
666 (fmt-list-start (car objlist) view strm indent nobjs)
667 (dolist (obj objlist)
668 (unless (and filter (not (funcall filter obj)))
669 (fmt-obj-start obj view strm indent)
670 (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
671 (fmt-obj-end obj view strm indent)
672 (fmt-subobj-start obj view strm indent)
673 (when (and subobjects (hyperobject-class-subobjects obj))
674 (dolist (subobj (hyperobject-class-subobjects obj))
675 (aif (slot-value obj (name-slot subobj))
677 (get-category-view (car (mklist it))
679 category strm (1+ indent) filter
680 subobjects refvars link-printer))))
681 (fmt-subobj-end obj view strm indent)))
682 (fmt-list-end (car objlist) view strm indent nobjs)))
686 (defun view (objs &key (stream *standard-output*) category view
687 filter subobjects refvars file-wrapper link-printer)
688 "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
689 (let-when (objlist (mklist objs))
691 (setq view (get-category-view (car objlist) category)))
693 (setq view (default-view (class-of (car objlist)))))
695 (fmt-file-start view stream))
696 (view-hyperobject objlist view category stream 0 filter subobjects refvars
699 (fmt-file-end view stream)))
705 (defun fmt-comma-integer (i)
706 (format nil "~:d" i))