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.44 2003/05/14 21:18:12 kevin Exp $
12 ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
13 ;;;; *************************************************************************
15 (in-package :hyperobject)
17 (eval-when (:compile-toplevel :execute)
18 (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2))))
21 (defclass object-view ()
22 ((object-class-name :initform nil :initarg :object-class-name
23 :accessor object-class-name
24 :documentation "Name of class of object to be viewed.")
25 (object-class :initform nil :initarg :object-class
26 :accessor object-class
27 :documentation "Class of object to be viewed.")
28 (slots :initform nil :initarg :slots :accessor slots
29 :documentation "List of effective slots for object to be viewed.")
30 (name :initform nil :initarg :name :accessor name
31 :documentation "Name for this view.")
32 (category :initform nil :initarg :category :accessor category
33 :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.")
34 (source-code :initform nil :initarg :source-code :accessor source-code
35 :documentation "Source code for generating view.")
36 (country-language :initform :en :initarg :country-language
37 :documentation "Country's Language for this view.")
39 (file-start-str :type (or string null) :initform nil :initarg :file-start-str
40 :accessor file-start-str)
41 (file-end-str :type (or string null) :initform nil :initarg :file-end-str
42 :accessor file-end-str)
43 (list-start-str-or-func :type (or string function null) :initform nil
44 :initarg :list-start-str-or-func
45 :accessor list-start-str-or-func)
46 (list-start-indent :initform nil :initarg :list-start-indent
47 :accessor list-start-indent)
48 (list-end-str-or-func :type (or string function null) :initform nil
49 :initarg :list-end-str-or-func
50 :accessor list-end-str-or-func)
51 (list-end-indent :initform nil :initarg :list-end-indent
52 :accessor list-end-indent)
53 (obj-start-str-or-func :type (or string function null) :initform nil :initarg :obj-start-str-or-func
54 :accessor obj-start-str-or-func)
55 (obj-start-indent :initform nil :initarg :obj-start-indent
56 :accessor obj-start-indent)
57 (obj-end-str-or-func :type (or string function null) :initform nil :initarg :obj-end-str-or-func
58 :accessor obj-end-str-or-func)
59 (obj-end-indent :initform nil :initarg :obj-end-indent
60 :accessor obj-end-indent)
61 (obj-data-indent :initform nil :initarg :obj-data-indent
62 :accessor obj-data-indent)
63 (obj-data-func :type (or function null) :initform nil
64 :initarg :obj-data-func
65 :accessor obj-data-func)
66 (obj-data-print-code :type (or function null) :initform nil
67 :initarg :obj-data-print-code
68 :accessor obj-data-print-code)
69 (obj-data-end-str :type (or string null) :initform nil
70 :initarg :obj-data-end-str
71 :accessor obj-data-end-str)
72 (link-slots :type list :initform nil
73 :documentation "List of slot names that have hyperlinks"
75 (link-page-name :type (or string null) :initform nil :initarg :link-page-name
76 :accessor link-page-name)
77 (link-href-start :type (or string null) :initform nil :initarg :link-href-start
78 :accessor link-href-start)
79 (link-href-end :type (or string null) :initform nil :initarg :link-href-end
80 :accessor link-href-end)
81 (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand
82 :accessor link-ampersand))
83 (:default-initargs :link-page-name "disp-func1")
84 (:documentation "View class for a hyperobject"))
87 (defun get-category-view (obj category &optional slots)
88 "Find or make a category view for an object"
89 (let ((obj-class (class-of obj)))
91 (default-view obj-class)
92 (aif (find category (views obj-class) :key #'category)
95 (make-instance 'object-view
96 :object-class-name (class-name obj-class)
97 :object-class obj-class
100 (push view (views obj-class))
103 ;;;; *************************************************************************
104 ;;;; Metaclass Intialization
105 ;;;; *************************************************************************
107 (defun finalize-views (cl)
108 "Finalize all views that are given on a objects initialization"
109 (unless (default-print-slots cl)
110 (setf (default-print-slots cl)
111 (mapcar #'slot-definition-name (class-slots cl))))
113 (dolist (view-def (views cl))
114 (push (make-object-view cl view-def) views))
115 (setf (views cl) (nreverse views)))
118 (setf (default-view cl) (make-object-view cl (default-view cl))))
120 (setf (default-view cl) (make-object-view cl (car (views cl)))))
122 (setf (default-view cl) (make-object-view cl :default)))))
124 (defun make-object-view (cl view-def)
125 "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
127 ((typep view-def 'object-view)
129 ((eq view-def :default)
130 (let* ((name (class-name cl))
131 (view (make-instance 'object-view :name "automatic"
132 :object-class-name name
134 :category :compact-text)))
137 (eval `(make-instance ,view-def)))
139 (error "Invalid parameter to make-object-view: ~S" view-def))))
141 (defmethod initialize-instance :after ((view object-view)
142 &rest initargs &key &allow-other-keys)
143 (initialize-view (object-class view) view))
145 (defun initialize-view (obj-cl view)
146 "Calculate all view slots for a hyperobject class"
149 (initialize-view-by-category obj-cl view))
151 (initialize-view-by-source-code obj-cl view))
153 (setf (category view) :compact-text)
154 (initialize-view-by-category obj-cl view))))
156 (defun initialize-view-by-source-code (obj-cl view)
157 "Initialize a view based upon a source code"
158 (let ((source-code (source-code view)))
159 (error "not implemented")
163 (defmacro write-simple (v s)
166 (write-string ,v ,s))
169 (excl::print-fixnum ,s 10 ,v))
171 (write-string (symbol-name ,v) ,s))
173 (write-string (write-to-string ,v) ,s))))
175 (defun write-ho-value (obj name type formatter cdata strm)
176 (declare (ignorable type))
177 (let* ((slot-data (slot-value obj name))
178 (fmt-data (if formatter
179 (funcall formatter slot-data)
182 (kmrcl:xml-cdata fmt-data)
184 (write-simple data strm)))
187 (defun ppfc-html (title name type formatter cdata print-func)
188 (vector-push-extend '(write-string "<span class=\"" s) print-func)
189 (vector-push-extend `(write-string ,title s) print-func)
190 (vector-push-extend '(write-string "\">" s) print-func)
191 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
192 (vector-push-extend '(write-string "</span>" s) print-func))
194 (defun ppfc-xml (tag name type formatter cdata print-func)
195 (vector-push-extend '(write-char #\< s) print-func)
196 (vector-push-extend `(write-string ,tag s) print-func)
197 (vector-push-extend '(write-char #\> s) print-func)
198 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
199 (vector-push-extend '(write-string "</" s) print-func)
200 (vector-push-extend `(write-string ,tag s) print-func)
201 (vector-push-extend '(write-char #\> s) print-func))
203 (defun ppfc-html-labels (label name type formatter cdata print-func)
204 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
205 (vector-push-extend `(write-string ,label s) print-func)
206 (vector-push-extend '(write-string "</span> " s) print-func)
207 (ppfc-html label name type formatter cdata print-func))
209 (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
210 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
211 (vector-push-extend `(write-string ,label s) print-func)
212 (vector-push-extend '(write-string "</span> " s) print-func)
213 (ppfc-html tag name type formatter cdata print-func))
215 (defun ppfc-xml-labels (label tag name type formatter cdata print-func)
216 (vector-push-extend '(write-string "<label>" s) print-func)
217 (vector-push-extend `(write-string ,label s) print-func)
218 (vector-push-extend '(write-string "</label> " s) print-func)
219 (ppfc-xml tag name type formatter cdata print-func))
221 (defun ppfc-html-link (name type formatter cdata nlink print-func)
222 (declare (fixnum nlink))
223 (vector-push-extend '(write-char #\< s) print-func)
224 (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)
225 (vector-push-extend '(write-char #\> s) print-func)
226 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
227 (vector-push-extend '(write-string "</" s) print-func)
228 (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)
229 (vector-push-extend '(write-char #\> s) print-func))
231 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
232 (vector-push-extend '(write-string "<label>" s) print-func)
233 (vector-push-extend `(write-string ,label s) print-func)
234 (vector-push-extend '(write-string "</label> " s) print-func)
235 (ppfc-html-link name type formatter cdata nlink print-func))
237 (defun push-print-fun-code (category slot nlink print-func)
238 (let* ((formatter (esd-print-formatter slot))
239 (name (slot-definition-name slot))
240 (namestr-lower (string-downcase (symbol-name name)))
241 (xml-namestr (escape-xml-string namestr-lower))
242 (xml-tag (escape-xml-string namestr-lower))
243 (type (slot-value slot 'type))
245 (and (in category :xml :xhtml :xml-link :xhtml-link
246 :xml-labels :ie-xml-labels
247 :xhtml-link-labels :xml-link-labels :ie-xml-link
250 (lisp-type-is-a-string type))))))
251 (hyperlink (esd-hyperlink slot)))
256 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
257 (:compact-text-labels
258 (vector-push-extend `(write-string ,namestr-lower s) print-func)
259 (vector-push-extend '(write-char #\space s) print-func)
261 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
263 (ppfc-html namestr-lower name type formatter cdata print-func))
265 (ppfc-xml xml-tag name type formatter cdata print-func))
267 (ppfc-html-labels namestr-lower name type formatter cdata print-func))
269 (ppfc-xhtml-labels xml-namestr namestr-lower name type formatter cdata print-func))
271 (ppfc-xml-labels xml-namestr xml-tag name type formatter cdata print-func))
272 ((or :html-link :xhtml-link)
274 (ppfc-html-link name type formatter cdata nlink print-func)
275 (ppfc-html namestr-lower name type formatter cdata print-func)))
276 ((or :xml-link :ie-xml-link)
278 (ppfc-html-link name type formatter cdata nlink print-func)
279 (ppfc-xml xml-tag name type formatter cdata print-func)))
282 (ppfc-html-link-labels namestr-lower name type formatter cdata nlink
284 (ppfc-html-labels namestr-lower name type formatter cdata print-func)))
287 (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
289 (ppfc-xhtml-labels xml-tag namestr-lower name type formatter cdata
291 ((or :xml-link-labels :ie-xml-link-labels)
293 (ppfc-html-link-labels xml-namestr name type formatter cdata nlink
295 (ppfc-xml-labels xml-tag namestr-lower name type formatter cdata
299 (defun view-has-links-p (view)
300 (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link
301 :html-link-labels :xhtml-link-labels :xml-link-labels
302 :ie-xml-link-labels))
304 (defun initialize-view-by-category (obj-cl view)
305 "Initialize a view based upon a preset category"
306 (unless (in (category view) :compact-text :compact-text-labels
307 :html :html-labels :html-link-labels
308 :xhtml :xhtml-labels :xhtml-link-labels
309 :xhtml-link :html-link
310 :xml :xml-labels :xml-link :ie-xml-link
311 :xml-link-labels :ie-xml-link-labels)
312 (error "Unknown view category ~A" (category view)))
314 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
317 (print-func (make-array 10 :fill-pointer 0 :adjustable t)))
319 (do* ((slots (slots view) (cdr slots))
320 (slot-name (car slots) (car slots))
321 (slot (find-slot-by-name obj-cl slot-name)
322 (find-slot-by-name obj-cl slot-name)))
325 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
327 (push-print-fun-code (category view) slot (length links) print-func)
328 (when (> (length slots) 1)
329 (vector-push-extend '(write-char #\space s) print-func))
331 (when (and (view-has-links-p view) (esd-hyperlink slot))
332 (push (slot-definition-name slot) links)))
334 (when (plusp (length print-func))
335 (setf (obj-data-print-code view) `(lambda (x s links)
336 (declare (ignorable links))
337 ,@(map 'list #'identity print-func)))
338 (setf (obj-data-func view)
339 (compile nil (eval (obj-data-print-code view)))))
341 (setf (link-slots view) (nreverse links)))
343 (finalize-view-by-category view)
346 (defun finalize-view-by-category (view)
347 (case (category view)
348 ((or :compact-text :compact-text-labels)
349 (initialize-text-view view))
350 ((or :html :xhtml :html-labels :xhtml-labels)
351 (initialize-html-view view))
352 ((or :xml :xml-labels)
353 (initialize-xml-view view))
354 ((or :html-link :html-link-labels)
355 (initialize-html-view view)
356 (setf (link-href-start view) "a href=")
357 (setf (link-href-end view) "a")
358 (setf (link-ampersand view) "&"))
359 ((or :xhtml-link :xhtml-link-labels)
360 (initialize-html-view view)
361 (setf (link-href-start view) "a href=")
362 (setf (link-href-end view) "a")
363 (setf (link-ampersand view) "&"))
364 ((or :xml-link :xml-link-labels)
365 (initialize-xml-view view)
366 (setf (link-href-start view)
367 "xmllink xlink:type=\"simple\" xlink:href=")
368 (setf (link-href-end view) "xmllink")
369 (setf (link-ampersand view) "&"))
370 ((or :ie-xml-link :ie-xml-link-labels)
371 (initialize-xml-view view)
372 (setf (link-href-start view) "html:a href=")
373 (setf (link-href-end view) "html:a")
374 (setf (link-ampersand view) "&"))))
377 (defun initialize-view-by-category (obj-cl view)
378 "Initialize a view based upon a preset category"
383 (category (category view)))
385 (unless (in category :compact-text :compact-text-labels
386 :html :html-labels :html-link-labels
387 :xhtml :xhtml-labels :xhtml-link-labels
388 :xml :xml-labels :xml-link :ie-xml-link
389 :xml-link-labels :ie-xml-link-labels)
390 (error "Unknown view category ~A" category))
393 (setf (slots view) (default-print-slots obj-cl)))
394 (dolist (slot-name (slots view))
395 (let ((slot (find-slot-by-name obj-cl slot-name)))
397 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
398 (let* ((name (slot-definition-name slot))
399 (namestr-lower (string-downcase (symbol-name name)))
400 (xml-namestr (escape-xml-string namestr-lower))
401 (xml-tag (escape-xml-string namestr-lower))
402 (type (slot-value slot 'type))
403 (print-formatter (esd-print-formatter slot)))
408 (setq first-field nil))
410 (string-append fmtstr " ")))
414 ((or :integer :fixnum)
422 (string-append fmtstr value-fmt))
423 (:compact-text-labels
424 (string-append fmtstr namestr-lower " " value-fmt))
426 (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>")))
428 (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">")))
430 (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
432 (string-append fmtstr (concatenate 'string "<span class=\"label\">" xml-namestr "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>")))
434 (string-append fmtstr (concatenate 'string "<label>" xml-namestr "</label> <" xml-tag ">" value-fmt "</" xml-tag ">")))
435 ((or :html-link :xhtml-link)
437 (if (esd-hyperlink slot)
438 (string-append fmtstr "<~~a>" value-fmt "</~~a>")
439 (string-append fmtstr (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))))
440 ((or :xml-link :ie-xml-link)
442 (if (esd-hyperlink slot)
443 (string-append fmtstr "<~~a>" value-fmt "</~~a>")
444 (string-append fmtstr (concatenate 'string "<" xml-tag ">" value-fmt "</" xml-tag ">"))))
447 (if (esd-hyperlink slot)
448 (string-append fmtstr "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
449 (string-append fmtstr (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
452 (if (esd-hyperlink slot)
453 (string-append fmtstr "<span class=\"label\">" xml-namestr "</span> <~~a>" value-fmt "</~~a>")
454 (string-append fmtstr (concatenate 'string "<span class=\"label\">" xml-namestr "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))))
455 ((or :xml-link-labels :ie-xml-link-labels)
457 (if (esd-hyperlink slot)
458 (string-append fmtstr "<label>" xml-namestr "</label> <~~a>" value-fmt "</~~a>")
459 (string-append fmtstr (concatenate 'string "<label>" xml-namestr "</label> <" xml-tag ">" value-fmt "</" xml-tag ">")))))
462 (let ((func (if print-formatter
463 `(,print-formatter (slot-value x (quote ,name)))
464 `(slot-value x (quote ,name)))))
465 (when (and (in category :xml :xhtml :xml-link :xhtml-link
466 :xml-labels :ie-xml-labels
467 :xhtml-link-labels :xml-link-labels :ie-xml-link
470 (lisp-type-is-a-string type)))
471 (setq func `(kmrcl:xml-cdata ,func)))
472 (push func value-func))
477 (compile nil (eval `(lambda (x) (values ,@(nreverse value-func)))))))
479 (setf (obj-data-fmtstr view) fmtstr)
480 (setf (obj-data-value-func view) value-func)
481 (setf (link-slots view) (nreverse links))
484 ((or :compact-text :compact-text-labels)
485 (initialize-text-view view))
486 ((or :html :xhtml :html-labels :xhtml-labels)
487 (initialize-html-view view))
488 ((or :xml :xml-labels)
489 (initialize-xml-view view))
490 ((or :html-link :html-link-labels)
491 (initialize-html-view view)
492 (setf (link-href-start view) "a href=")
493 (setf (link-href-end view) "a")
494 (setf (link-ampersand view) "&"))
495 ((or :xhtml-link :xhtml-link-labels)
496 (initialize-html-view view)
497 (setf (link-href-start view) "a href=")
498 (setf (link-href-end view) "a")
499 (setf (link-ampersand view) "&"))
500 ((or :xml-link :xml-link-labels)
501 (initialize-xml-view view)
502 (setf (link-href-start view)
503 "xmllink xlink:type=\"simple\" xlink:href=")
504 (setf (link-href-end view) "xmllink")
505 (setf (link-ampersand view) "&"))
506 ((or :ie-xml-link :ie-xml-link-labels)
507 (initialize-xml-view view)
508 (setf (link-href-start view) "html:a href=")
509 (setf (link-href-end view) "html:a")
510 (setf (link-ampersand view) "&"))))
514 ;;;; *************************************************************************
515 ;;;; View Data Format Section
516 ;;;; *************************************************************************
518 (defun class-name-of (obj)
519 (string-downcase (class-name (class-of obj))))
521 (defvar +newline-string+ (format nil "~%"))
523 (defun write-user-name-maybe-plural (obj nitems strm)
526 (hyperobject-class-user-name-plural obj)
527 (hyperobject-class-user-name obj))
530 (defun initialize-text-view (view)
531 (setf (list-start-str-or-func view)
533 (eval '(lambda (obj nitems strm)
534 (write-user-name-maybe-plural obj nitems strm)
535 (write-char #\: strm)
536 (write-char #\Newline strm)))))
537 (setf (list-start-indent view) t)
538 (setf (obj-data-indent view) t)
539 (setf (obj-data-end-str view) +newline-string+))
541 (defun html-list-start-func (obj nitems strm)
542 (write-string "<p><b>" strm)
543 (write-user-name-maybe-plural obj nitems strm)
544 (write-string ":</b></p><div class=\"" strm)
545 (write-string (class-name-of obj) strm)
546 (write-string "\"><ul>" strm)
547 (write-char #\newline strm))
549 (defun initialize-html-view (view)
550 (initialize-text-view view)
551 (setf (file-start-str view) (format nil "<html><body>~%"))
552 (setf (file-end-str view) (format nil "</body><html>~%"))
553 (setf (list-start-indent view) t)
554 (setf (list-start-str-or-func view) #'html-list-start-func)
555 (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
556 (setf (list-end-indent view) t)
557 (setf (obj-start-indent view) t)
558 (setf (obj-start-str-or-func view) "<li>")
559 (setf (obj-end-indent view) t)
560 (setf (obj-end-str-or-func view) (format nil "</li>~%"))
561 (setf (obj-data-indent view) nil))
563 (defun initialize-xhtml-view (view)
564 (initialize-text-view view)
565 (setf (file-start-str view) (format nil "<html><body>~%"))
566 (setf (file-end-str view) (format nil "</body><html>~%"))
567 (setf (list-start-indent view) t)
568 (setf (list-start-str-or-func view) #'html-list-start-func)
569 (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
570 (setf (list-end-indent view) t)
571 (setf (obj-start-indent view) t)
572 (setf (obj-start-str-or-func view) "<li>")
573 (setf (obj-end-indent view) t)
574 (setf (obj-end-str-or-func view) (format nil "</li>~%"))
575 (setf (obj-data-indent view) nil))
577 (defun xmlformat-list-end-func (x strm)
578 (write-string "</" strm)
579 (write-string (class-name-of x) strm)
580 (write-string "list" strm)
581 (write-string ">" strm)
582 (write-char #\newline strm))
584 (defun xmlformat-list-start-func (x nitems strm)
585 (write-char #\< strm)
586 (write-string (class-name-of x) strm)
587 (write-string "list><title>" strm)
588 (write-user-name-maybe-plural x nitems strm)
589 (write-string ":</title>" strm)
590 (write-char #\newline strm))
592 (defun initialize-xml-view (view)
593 (initialize-text-view view)
594 (setf (file-start-str view) "") ; (std-xml-header)
595 (setf (list-start-indent view) t)
596 (setf (list-start-str-or-func view) #'xmlformat-list-start-func)
597 (setf (list-end-indent view) t)
598 (setf (list-end-str-or-func view) #'xmlformat-list-end-func)
599 (setf (obj-start-str-or-func view) (format nil "<~(~a~)>" (object-class-name view)))
600 (setf (obj-start-indent view) t)
601 (setf (obj-end-str-or-func view) (format nil "</~(~a~)>~%" (object-class-name view)))
602 (setf (obj-end-indent view) nil)
603 (setf (obj-data-indent view) nil))
606 ;;; File Start and Ends
608 (defun fmt-file-start (view strm)
609 (awhen (file-start-str view)
610 (write-string it strm)))
612 (defun fmt-file-end (view strm)
613 (awhen (file-end-str view)
614 (write-string it strm)))
616 ;;; List Start and Ends
618 (defun fmt-list-start (obj view strm indent num-items)
619 (when (list-start-indent view)
620 (indent-spaces indent strm))
621 (awhen (list-start-str-or-func view)
623 (write-string it strm)
624 (funcall it obj num-items strm))))
626 (defun fmt-list-end (obj view strm indent num-items)
627 (declare (ignore num-items))
628 (when (list-end-indent view)
629 (indent-spaces indent strm))
630 (awhen (list-end-str-or-func view)
632 (write-string it strm)
633 (funcall it obj strm))))
635 ;;; Object Start and Ends
637 (defun fmt-obj-start (obj view strm indent)
638 (when (obj-start-indent view)
639 (indent-spaces indent strm))
640 (awhen (obj-start-str-or-func view)
642 (write-string it strm)
643 (funcall it obj strm))))
645 (defun fmt-obj-end (obj view strm indent)
646 (when (obj-end-indent view)
647 (indent-spaces indent strm))
648 (awhen (obj-end-str-or-func view)
650 (write-string it strm)
651 (funcall it obj strm))))
656 (defun make-link-start (view fieldfunc fieldvalue refvars)
657 (with-output-to-string (s)
658 (write-string (link-href-start view) s)
660 (write-string (make-url (link-page-name view)) s)
661 (write-string "?func=" s)
662 (write-simple fieldfunc s)
663 (write-string (link-ampersand view) s)
664 (write-string "key=" s)
665 (write-simple fieldvalue s)
666 (dolist (var refvars)
667 (write-string (link-ampersand view) s)
668 (write-simple (car var) s)
670 (write-simple (cdr var) s))
673 (defun make-link-end (obj view fieldname)
674 (declare (ignore obj fieldname))
675 (link-href-end view))
677 (defun fmt-obj-data (obj view strm indent refvars)
678 (when (obj-data-indent view)
679 (indent-spaces indent strm))
680 (if (link-slots view)
681 (fmt-obj-data-with-link obj view strm refvars)
682 (fmt-obj-data-plain obj view strm))
683 (awhen (obj-data-end-str view)
684 (write-string it strm)))
686 (defun fmt-obj-data-plain (obj view strm)
687 (awhen (obj-data-func view)
688 (funcall it obj strm nil)))
690 (defun fmt-obj-data-with-link (obj view strm refvars)
691 (let ((refvalues '()))
692 ;; make list of hyperlink link fields for printing to refstr template
693 (dolist (name (link-slots view))
694 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
695 (push (make-link-start view (lookup it) (slot-value obj name)
696 (append (link-parameters it) refvars))
698 (push (make-link-end obj view name) refvalues)))
699 (funcall (obj-data-func view) obj strm (nreverse refvalues))))
701 (defun obj-data (obj view)
702 "Returns the objects data as a string. Used by common-graphics outline function"
703 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
705 ;;; Display method for objects
708 (defun load-all-subobjects (objs)
709 "Load all subobjects if they have not already been loaded."
710 (dolist (obj (mklist objs))
711 (dolist (subobj (hyperobject-class-subobjects obj))
712 (awhen (slot-value obj (name-slot subobj))
713 (load-all-subobjects it))))
716 (defun view-hyperobject (objs view category strm &optional (indent 0) filter
718 "Display a single or list of hyperobject-class instances and their subobjects"
719 (declare (fixnum indent))
720 (let-when (objlist (mklist objs))
721 (let ((nobjs (length objlist))
725 (*print-readably* nil)
728 (fmt-list-start (car objlist) view strm indent nobjs)
729 (dolist (obj objlist)
730 (unless (and filter (not (funcall filter obj)))
731 (fmt-obj-start obj view strm indent)
732 (fmt-obj-data obj view strm (1+ indent) refvars)
733 (when (and subobjects (hyperobject-class-subobjects obj))
734 (dolist (subobj (hyperobject-class-subobjects obj))
735 (aif (slot-value obj (name-slot subobj))
736 (view-hyperobject it (get-category-view (car (mklist it)) category)
737 category strm (1+ indent) filter
738 subobjects refvars))))
739 (fmt-obj-end obj view strm indent)))
740 (fmt-list-end (car objlist) view strm indent nobjs)))
744 (defun view (objs &key (stream *standard-output*) category view
745 filter subobjects refvars file-wrapper)
746 "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject"
747 (let-when (objlist (mklist objs))
749 (setq view (get-category-view (car objlist) category)))
751 (setq view (default-view (class-of (car objlist)))))
753 (fmt-file-start view stream))
754 (view-hyperobject objlist view category stream 0 filter subobjects refvars)
756 (fmt-file-end view stream)))
762 (defun fmt-comma-integer (i)
763 (format nil "~:d" i))