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.62 2003/07/19 20:32:48 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 :initform nil :initarg :object-class
20 :accessor object-class
21 :documentation "Class of object to be viewed.")
22 (slots :initform nil :initarg :slots :accessor slots
23 :documentation "List of effective slots for object to be viewed.")
24 (id :initform nil :initarg :id :accessor id
25 :documentation "id for this view.")
26 (source-code :initform nil :initarg :source-code :accessor source-code
27 :documentation "Source code for generating view.")
28 (country-language :initform :en :initarg :country-language
29 :documentation "Country's Language for this view.")
30 (printer :initform nil :initarg :printer :accessor printer
31 :documentation "default function that prints the object")
33 (file-start-str :type (or string null) :initform nil :initarg :file-start-str
34 :accessor file-start-str)
35 (file-end-str :type (or string null) :initform nil :initarg :file-end-str
36 :accessor file-end-str)
37 (list-start-printer :type (or string function null) :initform nil
38 :initarg :list-start-printer
39 :accessor list-start-printer)
40 (list-start-indent :initform nil :initarg :list-start-indent
41 :accessor list-start-indent)
42 (list-end-printer :type (or string function null) :initform nil
43 :initarg :list-end-printer
44 :accessor list-end-printer)
45 (list-end-indent :initform nil :initarg :list-end-indent
46 :accessor list-end-indent)
47 (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer
48 :accessor obj-start-printer)
49 (obj-start-indent :initform nil :initarg :obj-start-indent
50 :accessor obj-start-indent)
51 (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer
52 :accessor obj-end-printer)
53 (obj-end-indent :initform nil :initarg :obj-end-indent
54 :accessor obj-end-indent)
55 (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer
56 :accessor subobj-start-printer)
57 (subobj-start-indent :initform nil :initarg :subobj-start-indent
58 :accessor subobj-start-indent)
59 (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer
60 :accessor subobj-end-printer)
61 (subobj-end-indent :initform nil :initarg :subobj-end-indent
62 :accessor subobj-end-indent)
63 (obj-data-indent :initform nil :initarg :obj-data-indent
64 :accessor obj-data-indent)
65 (obj-data-printer :type (or function null) :initform nil
66 :initarg :obj-data-printer
67 :accessor obj-data-printer)
68 (obj-data-print-code :type (or function null) :initform nil
69 :initarg :obj-data-print-code
70 :accessor obj-data-print-code)
71 (obj-data-start-printer :type (or function string null) :initform nil
72 :initarg :obj-data-start-printer
73 :accessor obj-data-start-printer)
74 (obj-data-end-printer :type (or string null) :initform nil
75 :initarg :obj-data-end-printer
76 :accessor obj-data-end-printer)
77 (indenter :type (or function null) :initform nil
79 :documentation "Function that performs hierarchical indenting")
80 (link-slots :type list :initform nil
81 :documentation "List of slot names that have hyperlinks"
83 (link-page :type (or string null) :initform nil
86 (link-href-start :type (or string null) :initform nil :initarg :link-href-start
87 :accessor link-href-start)
88 (link-href-end :type (or string null) :initform nil :initarg :link-href-end
89 :accessor link-href-end)
90 (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
91 :accessor link-ampersand))
92 (:default-initargs :link-page "lookup-func1")
93 (:documentation "View class for a hyperobject"))
96 (defun get-default-view-id (obj-cl)
101 (defun find-view-id-in-class-precedence (obj-cl vid)
102 "Looks for a view in class and parent classes"
103 (when (typep obj-cl 'hyperobject-class)
104 (aif (find vid (views obj-cl) :key #'id :test #'eq)
108 (setq cpl (class-precedence-list obj-cl))
111 ;; can't get cpl unless class finalized
112 (make-instance (class-name obj-cl))
113 (setq cpl (class-precedence-list obj-cl))))
114 (find-view-id-in-class-precedence (second cpl) vid)))))
117 (defun get-view-id (obj vid &optional slots)
118 "Find or make a category view for an object"
119 (let ((obj-cl (class-of obj)))
121 (setq vid (get-default-view-id obj-cl)))
122 (aif (find-view-id-in-class-precedence obj-cl vid)
125 (make-instance 'object-view
126 :object-class (class-name obj-cl)
129 (push view (views obj-cl))
132 ;;;; *************************************************************************
133 ;;;; Metaclass Intialization
134 ;;;; *************************************************************************
136 (defun finalize-views (cl)
137 "Finalize all views that are given on a objects initialization"
138 (unless (default-print-slots cl)
139 (setf (default-print-slots cl)
140 (mapcar #'slot-definition-name (class-slots cl))))
142 (loop for view-def in (direct-views cl)
143 collect (make-object-view cl view-def))))
145 (defun make-object-view (cl view-def)
146 "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
148 ((typep view-def 'object-view)
150 ((eq view-def :default)
151 (make-instance 'object-view
152 :object-class (class-name cl)
155 (make-instance 'object-view
156 :object-class (class-name cl)
157 :id (getf view-def :id)
158 :slots (getf view-def :slots)
159 :source-code (getf view-def :source-code)))
161 (error "Invalid parameter to make-object-view: ~S" view-def))))
163 (defmethod initialize-instance :after ((self object-view)
167 (initialize-view self))
169 (defun initialize-view (view)
170 "Calculate all view slots for a hyperobject class"
171 (let ((obj-cl (find-class (object-class view))))
174 (initialize-view-by-source-code view))
176 (initialize-view-by-id obj-cl view))
178 (setf (id view) :compact-text)
179 (initialize-view-by-id obj-cl view)))))
183 (defun initialize-view-by-source-code (view)
184 "Initialize a view based upon a source code"
185 (let* ((source-code (source-code view))
187 (,(intern (symbol-name '#:self)
188 (symbol-package (object-class view)))
189 ,(intern (symbol-name '#:s)
190 (symbol-package (object-class view))))
192 ,(intern (symbol-name '#:self)
193 (symbol-package (object-class view)))
194 ,(intern (symbol-name '#:s)
195 (symbol-package (object-class view)))))
196 (with-slots ,(slots view)
197 ,(intern (symbol-name '#:self)
198 (symbol-package (object-class view)))
201 (compile nil (eval printer)))))
203 (defmacro write-simple (v s)
206 (write-string ,v ,s))
208 (write-fixnum ,v ,s))
210 (write-string (symbol-name ,v) ,s))
212 (write-string (write-to-string ,v) ,s))))
214 (defun write-ho-value (obj name type formatter cdata strm)
215 (declare (ignorable type))
216 (let* ((slot-data (slot-value obj name))
217 (fmt-data (if formatter
218 (funcall formatter slot-data)
221 (write-xml-cdata fmt-data strm)
222 (write-simple fmt-data strm))))
224 (defun ppfc-html (title name type formatter cdata print-func)
225 (vector-push-extend '(write-string "<span class=\"" s) print-func)
226 (vector-push-extend `(write-string ,title s) print-func)
227 (vector-push-extend '(write-string "\">" s) print-func)
228 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
229 (vector-push-extend '(write-string "</span>" s) print-func))
231 (defun ppfc-xml (tag name type formatter cdata print-func)
232 (vector-push-extend '(write-char #\< s) print-func)
233 (vector-push-extend `(write-string ,tag 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 ,tag s) print-func)
238 (vector-push-extend '(write-char #\> s) print-func))
240 (defun ppfc-html-labels (label name type formatter cdata 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 label name type formatter cdata print-func))
246 (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
247 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
248 (vector-push-extend `(write-string ,label s) print-func)
249 (vector-push-extend '(write-string "</span> " s) print-func)
250 (ppfc-html tag name type formatter cdata print-func))
252 (defun ppfc-xml-labels (label tag name type formatter cdata print-func)
253 (vector-push-extend '(write-string "<label>" s) print-func)
254 (vector-push-extend `(write-string ,label s) print-func)
255 (vector-push-extend '(write-string "</label> " s) print-func)
256 (ppfc-xml tag name type formatter cdata print-func))
258 (defun ppfc-html-link (name type formatter cdata nlink print-func)
259 (declare (fixnum nlink))
260 (vector-push-extend '(write-char #\< s) print-func)
261 (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)
262 (vector-push-extend '(write-char #\> s) print-func)
263 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
264 (vector-push-extend '(write-string "</" s) print-func)
265 (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)
266 (vector-push-extend '(write-char #\> s) print-func))
268 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
269 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
270 (vector-push-extend `(write-string ,label s) print-func)
271 (vector-push-extend '(write-string "</span> " s) print-func)
272 (ppfc-html-link name type formatter cdata nlink print-func))
274 (defun push-print-fun-code (vid slot nlink print-func)
275 (let* ((formatter (esd-print-formatter slot))
276 (name (slot-definition-name slot))
277 (user-name (esd-user-name slot))
278 (xml-user-name (escape-xml-string user-name))
279 (xml-tag (escape-xml-string user-name))
280 (type (slot-value slot 'type))
282 (and (in vid :xml :xhtml :xml-link :xhtml-link
283 :xml-labels :ie-xml-labels
284 :xhtml-link-labels :xml-link-labels :ie-xml-link
287 (lisp-type-is-a-string type))))))
288 (hyperlink (esd-hyperlink slot)))
293 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
294 (:compact-text-labels
295 (vector-push-extend `(write-string ,user-name s) print-func)
296 (vector-push-extend '(write-char #\space s) print-func)
298 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
300 (ppfc-html user-name name type formatter cdata print-func))
302 (ppfc-xml xml-tag name type formatter cdata print-func))
304 (ppfc-html-labels user-name name type formatter cdata print-func))
306 (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
308 (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
309 ((or :html-link :xhtml-link)
311 (ppfc-html-link name type formatter cdata nlink print-func)
312 (ppfc-html user-name name type formatter cdata print-func)))
313 ((or :xml-link :ie-xml-link)
315 (ppfc-html-link name type formatter cdata nlink print-func)
316 (ppfc-xml xml-tag name type formatter cdata print-func)))
319 (ppfc-html-link-labels user-name name type formatter cdata nlink
321 (ppfc-html-labels user-name name type formatter cdata print-func)))
324 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
326 (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
328 ((or :xml-link-labels :ie-xml-link-labels)
330 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
332 (ppfc-xml-labels xml-tag user-name name type formatter cdata
336 (defun view-has-links-p (view)
337 (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link
338 :html-link-labels :xhtml-link-labels :xml-link-labels
339 :ie-xml-link-labels))
341 (defun creatable-view-id-p (obj-cl vid)
342 "Returns T if a view id can be created for this class"
343 (declare (ignore obj-cl))
344 (in vid :compact-text :compact-text-labels
345 :html :html-labels :html-link-labels
346 :xhtml :xhtml-labels :xhtml-link-labels
347 :xhtml-link :html-link
348 :xml :xml-labels :xml-link :ie-xml-link
349 :xml-link-labels :ie-xml-link-labels
350 :display-table :edit-table))
352 (defun initialize-view-by-id (obj-cl view)
353 "Initialize a view based upon a preset vid"
354 (unless (creatable-view-id-p obj-cl (id view))
355 (error "Unable to automatically create view id ~A" (id view)))
357 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
360 (print-func (make-array 10 :fill-pointer 0 :adjustable t)))
362 (do* ((slots (slots view) (cdr slots))
363 (slot-name (car slots) (car slots))
364 (slot (find-slot-by-name obj-cl slot-name)
365 (find-slot-by-name obj-cl slot-name)))
368 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
370 (push-print-fun-code (id view) slot (length links) print-func)
371 (when (> (length slots) 1)
372 (vector-push-extend '(write-char #\space s) print-func))
374 (when (and (view-has-links-p view) (esd-hyperlink slot))
375 (push (slot-definition-name slot) links)))
377 (vector-push-extend 'x print-func) ;; return object
378 (setf (obj-data-print-code view) `(lambda (x s links)
379 (declare (ignorable s links))
380 ,@(map 'list #'identity print-func)))
381 (setf (obj-data-printer view)
382 (compile nil (eval (obj-data-print-code view))))
384 (setf (link-slots view) (nreverse links)))
386 (finalize-view-by-id view)
389 (defun finalize-view-by-id (view)
391 ((or :compact-text :compact-text-labels)
392 (initialize-text-view view))
393 ((or :html :html-labels)
394 (initialize-html-view view))
395 ((or :xhtml :xhtml-labels)
396 (initialize-xhtml-view view))
397 ((or :xml :xml-labels)
398 (initialize-xml-view view))
399 ((or :html-link :html-link-labels)
400 (initialize-html-view view)
401 (setf (link-href-start view) "a href=")
402 (setf (link-href-end view) "a")
403 (setf (link-ampersand view) "&"))
404 ((or :xhtml-link :xhtml-link-labels)
405 (initialize-xhtml-view view)
406 (setf (link-href-start view) "a href=")
407 (setf (link-href-end view) "a")
408 (setf (link-ampersand view) "&"))
409 ((or :xml-link :xml-link-labels)
410 (initialize-xml-view view)
411 (setf (link-href-start view)
412 "xmllink xlink:type=\"simple\" xlink:href=")
413 (setf (link-href-end view) "xmllink")
414 (setf (link-ampersand view) "&"))
415 ((or :ie-xml-link :ie-xml-link-labels)
416 (initialize-xml-view view)
417 (setf (link-href-start view) "html:a href=")
418 (setf (link-href-end view) "html:a")
419 (setf (link-ampersand view) "&"))))
422 ;;;; *************************************************************************
423 ;;;; View Data Format Section
424 ;;;; *************************************************************************
426 (defun class-name-of (obj)
427 (string-downcase (class-name (class-of obj))))
429 (defvar +newline-string+ (format nil "~%"))
431 (defun write-user-name-maybe-plural (obj nitems strm)
434 (hyperobject-class-user-name-plural obj)
435 (hyperobject-class-user-name obj))
438 (defun initialize-text-view (view)
439 (setf (list-start-printer view)
441 (eval '(lambda (obj nitems indent strm)
442 (declare (ignore indent))
443 (write-user-name-maybe-plural obj nitems strm)
444 (write-char #\: strm)
445 (write-char #\Newline strm)))))
446 (setf (list-start-indent view) t)
447 (setf (obj-data-indent view) t)
448 (setf (obj-data-end-printer view) +newline-string+)
449 (setf (indenter view) #'indent-spaces))
451 (defun html-list-start-func (obj nitems indent strm)
452 (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
453 (write-fixnum (+ indent indent) strm)
454 (write-string "em;\">" strm)
455 (write-user-name-maybe-plural obj nitems strm)
456 (write-string "</div>" strm)
457 (write-char #\newline strm)
458 (write-string "<ul>" strm)
459 (write-char #\newline strm))
461 (defun initialize-html-view (view)
462 (initialize-text-view view)
463 (setf (indenter view) #'indent-spaces)
464 (setf (file-start-str view) (format nil "<html><body>~%"))
465 (setf (file-end-str view) (format nil "</body><html>~%"))
466 (setf (list-start-indent view) t)
467 (setf (list-start-printer view) #'html-list-start-func)
468 (setf (list-end-printer view) (format nil "</ul>~%"))
469 (setf (list-end-indent view) t)
470 (setf (obj-start-indent view) nil)
471 (setf (obj-start-printer view) "<li>")
472 (setf (obj-end-indent view) nil)
473 (setf (obj-end-printer view) (format nil "</li>~%"))
474 (setf (obj-data-end-printer view) nil)
475 (setf (obj-data-indent view) nil))
477 (defun xhtml-list-start-func (obj nitems indent strm)
478 (write-string "<div class=\"ho-username\" :style=\"margin-left:" strm)
479 (write-fixnum (+ indent indent) strm)
480 (write-string "em;\">" strm)
481 (write-user-name-maybe-plural obj nitems strm)
482 (write-string "</div>" strm)
483 (write-string "<div :style=\"margin-left:" strm)
484 (write-fixnum (+ indent indent) strm)
485 (write-string "em;\">" strm)
486 (write-char #\newline strm))
488 (defun html-obj-start (obj indent strm)
489 (declare (ignore obj indent))
490 (write-string "<div style=\"margin-left:2em;\">" strm))
492 (defun initialize-xhtml-view (view)
493 (initialize-text-view view)
494 (setf (indenter view) #'indent-spaces)
495 (setf (file-start-str view) (format nil "<html><body>~%"))
496 (setf (file-end-str view) (format nil "</body><html>~%"))
497 (setf (list-start-indent view) nil)
498 (setf (list-start-printer view) #'xhtml-list-start-func)
499 (setf (list-end-printer view) (format nil "</div>~%"))
500 (setf (list-end-indent view) nil)
501 (setf (obj-start-indent view) nil)
502 (setf (obj-start-printer view) #'html-obj-start)
503 (setf (obj-end-printer view) (format nil "</div>~%"))
504 (setf (obj-data-indent view) nil))
506 (defun xmlformat-list-end-func (x strm)
507 (write-string "</" strm)
508 (write-string (class-name-of x) strm)
509 (write-string "list" strm)
510 (write-string ">" strm)
511 (write-char #\newline strm))
513 (defun xmlformat-list-start-func (x nitems indent strm)
514 (declare (ignore indent))
515 (write-char #\< strm)
516 (write-string (class-name-of x) strm)
517 (write-string "list><title>" strm)
518 (write-user-name-maybe-plural x nitems strm)
519 (write-string ":</title>" strm)
520 (write-char #\newline strm))
522 (defun initialize-xml-view (view)
523 (let ((name (string-downcase (symbol-name (object-class view)))))
524 (setf (file-start-str view) "") ; (std-xml-header)
525 (setf (list-start-indent view) t)
526 (setf (list-start-printer view) #'xmlformat-list-start-func)
527 (setf (list-end-indent view) t)
528 (setf (list-end-printer view) #'xmlformat-list-end-func)
529 (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
530 (setf (obj-start-indent view) t)
531 (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
532 (setf (subobj-end-indent view) nil)
533 (setf (obj-data-indent view) nil)))
536 ;;; File Start and Ends
538 (defun fmt-file-start (view strm)
539 (awhen (file-start-str view)
540 (write-string it strm)))
542 (defun fmt-file-end (view strm)
543 (awhen (file-end-str view)
544 (write-string it strm)))
546 ;;; List Start and Ends
548 (defun fmt-list-start (obj view strm indent num-items)
549 (when (list-start-indent view)
550 (awhen (indenter view)
551 (funcall it indent strm)))
552 (awhen (list-start-printer view)
554 (write-string it strm)
555 (funcall it obj num-items indent strm))))
557 (defun fmt-list-end (obj view strm indent num-items)
558 (declare (ignore num-items))
559 (when (list-end-indent view)
560 (awhen (indenter view)
561 (funcall it indent strm)))
562 (awhen (list-end-printer view)
564 (write-string it strm)
565 (funcall it obj strm))))
567 ;;; Object Start and Ends
570 (defun fmt-obj-start (obj view strm indent)
571 (when (obj-start-indent view)
572 (awhen (indenter view)
573 (funcall it indent strm)))
574 (awhen (obj-start-printer view)
576 (write-string it strm)
577 (funcall it obj indent strm))))
579 (defun fmt-obj-end (obj view strm indent)
580 (when (obj-end-indent view)
581 (awhen (indenter view)
582 (funcall it indent strm)))
583 (awhen (obj-end-printer view)
585 (write-string it strm)
586 (funcall it obj strm))))
588 (defun fmt-subobj-start (obj view strm indent)
589 (when (subobj-start-indent view)
590 (awhen (indenter view)
591 (funcall it indent strm)))
592 (awhen (subobj-start-printer view)
594 (write-string it strm)
595 (funcall it obj indent strm))))
597 (defun fmt-subobj-end (obj view strm indent)
598 (when (subobj-end-indent view)
599 (awhen (indenter view)
600 (funcall it indent strm)))
601 (awhen (subobj-end-printer view)
603 (write-string it strm)
604 (funcall it obj strm))))
609 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
610 (with-output-to-string (s)
611 (write-string (link-href-start view) s)
613 (let ((link-page (link-page view)))
616 (write-string (make-url link-page) s)
617 (write-string "?func=" s)
618 (write-simple fieldfunc s)
619 (write-string (link-ampersand view) s)
620 (write-string "key=" s)
621 (write-simple fieldvalue s)
622 (dolist (var refvars)
623 (write-string (link-ampersand view) s)
624 (write-simple (car var) s)
626 (write-simple (cdr var) s)))
628 (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
631 (defun make-link-end (obj view fieldname)
632 (declare (ignore obj fieldname))
633 (link-href-end view))
635 (defun fmt-obj-data (obj view strm indent refvars link-printer)
636 (awhen (obj-data-start-printer view)
638 (write-string it strm)
639 (funcall it obj strm)))
640 (when (obj-data-indent view)
641 (awhen (indenter view)
642 (funcall it indent strm)))
643 (if (link-slots view)
644 (fmt-obj-data-with-link obj view strm refvars link-printer)
645 (fmt-obj-data-plain obj view strm))
646 (awhen (obj-data-end-printer view)
648 (write-string it strm)
649 (funcall it obj strm))))
651 (defun fmt-obj-data-plain (obj view strm)
652 (awhen (obj-data-printer view)
653 (funcall it obj strm nil)))
655 (defun fmt-obj-data-with-link (obj view strm refvars link-printer)
656 (let ((refvalues '()))
657 (declare (dynamic-extent refvalues))
658 ;; make list of hyperlink link fields for printing to refstr template
659 (dolist (name (link-slots view))
660 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
661 (push (make-link-start view (lookup it) (slot-value obj name)
662 (append (link-parameters it) refvars)
665 (push (make-link-end obj view name) refvalues)))
666 (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
668 (defun obj-data (obj view)
669 "Returns the objects data as a string. Used by common-graphics outline function"
670 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
672 ;;; Display method for objects
675 (defun load-all-subobjects (objs)
676 "Load all subobjects if they have not already been loaded."
677 (dolist (obj (mklist objs))
678 (dolist (subobj (hyperobject-class-subobjects obj))
679 (awhen (slot-value obj (name-slot subobj))
680 (load-all-subobjects it))))
683 (defun view-subobjects (obj strm &optional vid (indent 0) filter
684 subobjects refvars link-printer)
685 (when (hyperobject-class-subobjects obj)
686 (dolist (subobj (hyperobject-class-subobjects obj))
687 (aif (slot-value obj (name-slot subobj))
689 it (get-view-id (car (mklist it)) vid)
690 strm vid (1+ indent) filter subobjects refvars
694 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
695 subobjects refvars link-printer)
696 "Display a single or list of hyperobject-class instances and their subobjects"
697 (let-when (objlist (mklist objs))
698 (let ((nobjs (length objlist))
702 (*print-readably* nil)
705 (fmt-list-start (car objlist) view strm indent nobjs)
706 (dolist (obj objlist)
707 (awhen (printer view)
708 (funcall it obj strm))
709 (unless (and filter (not (funcall filter obj)))
710 (fmt-obj-start obj view strm indent)
711 (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
712 (fmt-obj-end obj view strm indent)
714 (fmt-subobj-start obj view strm indent)
715 (view-subobjects obj strm vid indent filter subobjects
716 refvars link-printer)
717 (fmt-subobj-end obj view strm indent))))
718 (fmt-list-end (car objlist) view strm indent nobjs)))
722 (defun view (objs &key (stream *standard-output*) vid view
723 filter subobjects refvars file-wrapper link-printer)
724 "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
725 (let-when (objlist (mklist objs))
727 (setq view (get-view-id (car objlist) vid)))
729 (fmt-file-start view stream))
730 (view-hyperobject objlist view stream vid 0 filter subobjects refvars
733 (fmt-file-end view stream)))
739 (defun fmt-comma-integer (i)
740 (format nil "~:d" i))