1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: View methods for Hyperobjects
7 ;;;; Author: Kevin M. Rosenberg
12 ;;;; This file is Copyright (c) 2000-2004 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 "meta-search.html")
93 (:documentation "View class for a hyperobject"))
95 (defun get-default-view-id (obj-cl)
100 (defun find-view-id-in-class-precedence (obj-cl vid)
101 "Looks for a view in class and parent classes"
102 (when (typep obj-cl 'hyperobject-class)
103 (aif (find vid (views obj-cl) :key #'id :test #'eq)
107 (setq cpl (class-precedence-list obj-cl))
110 ;; can't get cpl unless class finalized
111 (make-instance (class-name obj-cl))
112 (setq cpl (class-precedence-list obj-cl))))
113 (find-view-id-in-class-precedence (second cpl) vid)))))
116 (defun get-view-id (obj vid &optional slots)
117 "Find or make a category view for an object"
118 (let ((obj-cl (class-of obj)))
120 (setq vid (get-default-view-id obj-cl)))
121 (aif (find-view-id-in-class-precedence obj-cl vid)
124 (make-instance 'object-view
125 :object-class (class-name obj-cl)
128 (push view (views obj-cl))
131 ;;;; *************************************************************************
132 ;;;; Metaclass Intialization
133 ;;;; *************************************************************************
135 (defun finalize-views (cl)
136 "Finalize all views that are given on a objects initialization"
137 (unless (default-print-slots cl)
138 (setf (default-print-slots cl)
139 (mapcar #'slot-definition-name (class-slots cl))))
141 (loop for view-def in (direct-views cl)
142 collect (make-object-view cl view-def))))
144 (defun make-object-view (cl view-def)
145 "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op"
147 ((typep view-def 'object-view)
149 ((eq view-def :default)
150 (make-instance 'object-view
151 :object-class (class-name cl)
154 (make-instance 'object-view
155 :object-class (class-name cl)
156 :id (getf view-def :id)
157 :slots (getf view-def :slots)
158 :source-code (getf view-def :source-code)))
160 (error "Invalid parameter to make-object-view: ~S" view-def))))
162 (defmethod initialize-instance :after ((self object-view)
166 (initialize-view self))
168 (defun initialize-view (view)
169 "Calculate all view slots for a hyperobject class"
170 (let ((obj-cl (find-class (object-class view))))
173 (initialize-view-by-source-code view))
175 (initialize-view-by-id obj-cl view))
177 (setf (id view) :compact-text)
178 (initialize-view-by-id obj-cl view)))))
182 (defun initialize-view-by-source-code (view)
183 "Initialize a view based upon a source code"
184 (let* ((source-code (source-code view))
186 (,(intern (symbol-name '#:self)
187 (symbol-package (object-class view)))
188 ,(intern (symbol-name '#:s)
189 (symbol-package (object-class view))))
191 ,(intern (symbol-name '#:self)
192 (symbol-package (object-class view)))
193 ,(intern (symbol-name '#:s)
194 (symbol-package (object-class view)))))
195 (with-slots ,(slots view)
196 ,(intern (symbol-name '#:self)
197 (symbol-package (object-class view)))
200 (compile nil (eval printer)))))
202 (defmacro write-simple (v s)
205 (write-string ,v ,s))
207 (write-fixnum ,v ,s))
209 (write-string (symbol-name ,v) ,s))
211 (write-string (write-to-string ,v) ,s))))
213 (defun write-ho-value (obj name type formatter cdata strm)
214 (declare (ignorable type))
215 (let* ((slot-data (slot-value obj name))
216 (fmt-data (if formatter
217 (funcall formatter slot-data)
220 (write-cdata fmt-data strm)
221 (write-simple fmt-data strm))))
223 (defun ppfc-html (title name type formatter cdata print-func)
224 (vector-push-extend '(write-string "<span class=\"" s) print-func)
225 (vector-push-extend `(write-string ,title s) print-func)
226 (vector-push-extend '(write-string "\">" s) print-func)
227 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
228 (vector-push-extend '(write-string "</span>" s) print-func))
230 (defun ppfc-xml (tag name type formatter cdata print-func)
231 (vector-push-extend '(write-char #\< s) print-func)
232 (vector-push-extend `(write-string ,tag s) print-func)
233 (vector-push-extend '(write-char #\> s) print-func)
234 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
235 (vector-push-extend '(write-string "</" s) print-func)
236 (vector-push-extend `(write-string ,tag s) print-func)
237 (vector-push-extend '(write-char #\> s) print-func))
239 (defun ppfc-display-table (title name type formatter cdata print-func)
240 (vector-push-extend '(write-string "<td>" s) print-func)
241 (ppfc-html title name type formatter cdata print-func)
242 (vector-push-extend '(write-string "</td>" s) print-func))
244 (defun ppfc-html-labels (label name type formatter cdata print-func)
245 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
246 (vector-push-extend `(write-string ,label s) print-func)
247 (vector-push-extend '(write-string "</span> " s) print-func)
248 (ppfc-html label name type formatter cdata print-func))
250 (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
251 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
252 (vector-push-extend `(write-string ,label s) print-func)
253 (vector-push-extend '(write-string "</span> " s) print-func)
254 (ppfc-html tag name type formatter cdata print-func))
256 (defun ppfc-xml-labels (label tag name type formatter cdata print-func)
257 (vector-push-extend '(write-string "<label>" s) print-func)
258 (vector-push-extend `(write-string ,label s) print-func)
259 (vector-push-extend '(write-string "</label> " s) print-func)
260 (ppfc-xml tag name type formatter cdata print-func))
262 (defun ppfc-html-link (name type formatter cdata nlink print-func)
263 (declare (fixnum nlink))
264 (vector-push-extend '(write-char #\< s) print-func)
265 (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)
266 (vector-push-extend '(write-char #\> s) print-func)
267 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
268 (vector-push-extend '(write-string "</" s) print-func)
269 (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)
270 (vector-push-extend '(write-char #\> s) print-func))
272 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
273 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
274 (vector-push-extend `(write-string ,label s) print-func)
275 (vector-push-extend '(write-string "</span> " s) print-func)
276 (ppfc-html-link name type formatter cdata nlink print-func))
278 (defun push-print-fun-code (vid slot nlink print-func)
279 (let* ((formatter (esd-print-formatter slot))
280 (name (slot-definition-name slot))
281 (user-name (esd-user-name slot))
282 (xml-user-name (escape-xml-string user-name))
283 (xml-tag (escape-xml-string user-name))
284 (type (slot-value slot #-sbcl 'type
285 #+sbcl 'sb-pcl::%type))
287 (and (in vid :xml :xhtml :xml-link :xhtml-link
288 :xml-labels :ie-xml-labels
289 :xhtml-link-labels :xml-link-labels :ie-xml-link
292 (lisp-type-is-a-string type))))))
293 (hyperlink (esd-hyperlink slot)))
298 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
299 (:compact-text-labels
300 (vector-push-extend `(write-string ,user-name s) print-func)
301 (vector-push-extend '(write-char #\space s) print-func)
303 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
305 (ppfc-html user-name name type formatter cdata print-func))
307 (ppfc-xml xml-tag name type formatter cdata print-func))
309 (ppfc-html-labels user-name name type formatter cdata print-func))
311 (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
312 ((:display-table :display-table-labels)
313 (ppfc-display-table user-name name type formatter cdata print-func))
315 (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
316 ((or :html-link :xhtml-link)
318 (ppfc-html-link name type formatter cdata nlink print-func)
319 (ppfc-html user-name name type formatter cdata print-func)))
320 ((or :xml-link :ie-xml-link)
322 (ppfc-html-link name type formatter cdata nlink print-func)
323 (ppfc-xml xml-tag name type formatter cdata print-func)))
326 (ppfc-html-link-labels user-name name type formatter cdata nlink
328 (ppfc-html-labels user-name name type formatter cdata print-func)))
331 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
333 (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
335 ((or :xml-link-labels :ie-xml-link-labels)
337 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
339 (ppfc-xml-labels xml-tag user-name name type formatter cdata
343 (defun view-has-links-p (view)
344 (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link
345 :html-link-labels :xhtml-link-labels :xml-link-labels
346 :ie-xml-link-labels))
348 (defun creatable-view-id-p (obj-cl vid)
349 "Returns T if a view id can be created for this class"
350 (declare (ignore obj-cl))
351 (in vid :compact-text :compact-text-labels
352 :html :html-labels :html-link-labels
353 :xhtml :xhtml-labels :xhtml-link-labels
354 :xhtml-link :html-link
355 :xml :xml-labels :xml-link :ie-xml-link
356 :xml-link-labels :ie-xml-link-labels
357 :display-table :display-table-labels :edit-table :edit-table-labels))
359 (defun initialize-view-by-id (obj-cl view)
360 "Initialize a view based upon a preset vid"
361 (unless (creatable-view-id-p obj-cl (id view))
362 (error "Unable to automatically create view id ~A" (id view)))
364 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
367 (print-func (make-array 20 :fill-pointer 0 :adjustable t)))
369 (do* ((slots (slots view) (cdr slots))
370 (slot-name (car slots) (car slots))
371 (slot (find-slot-by-name obj-cl slot-name)
372 (find-slot-by-name obj-cl slot-name)))
375 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
377 (push-print-fun-code (id view) slot (length links) print-func)
378 (when (> (length slots) 1)
379 (vector-push-extend '(write-char #\space s) print-func))
381 (when (and (view-has-links-p view) (esd-hyperlink slot))
382 (push (slot-definition-name slot) links)))
384 (vector-push-extend 'x print-func) ;; return object
385 (setf (obj-data-print-code view) `(lambda (x s links)
386 (declare (ignorable s links))
387 ,@(map 'list #'identity print-func)))
388 (setf (obj-data-printer view)
389 (compile nil (eval (obj-data-print-code view))))
391 (setf (link-slots view) (nreverse links)))
393 (finalize-view-by-id view)
396 (defun finalize-view-by-id (view)
398 ((or :compact-text :compact-text-labels)
399 (initialize-text-view view))
400 ((or :html :html-labels)
401 (initialize-html-view view))
402 ((or :xhtml :xhtml-labels)
403 (initialize-xhtml-view view))
404 ((or :xml :xml-labels)
405 (initialize-xml-view view))
406 ((or :html-link :html-link-labels)
407 (initialize-html-view view)
408 (setf (link-href-start view) "a href=")
409 (setf (link-href-end view) "a")
410 (setf (link-ampersand view) "&"))
411 ((or :xhtml-link :xhtml-link-labels)
412 (initialize-xhtml-view view)
413 (setf (link-href-start view) "a href=")
414 (setf (link-href-end view) "a")
415 (setf (link-ampersand view) "&"))
416 ((or :display-table :display-table-labels :edit-tables)
417 (initialize-table-view view)
418 (when (in (id view) :display-table-labels :edit-table-labels)
419 (setf (list-start-printer view) #'table-label-list-start-func))
420 (setf (link-href-start view) "a href=")
421 (setf (link-href-end view) "a")
422 (setf (link-ampersand view) "&"))
423 ((or :xml-link :xml-link-labels)
424 (initialize-xml-view view)
425 (setf (link-href-start view)
426 "xmllink xlink:type=\"simple\" xlink:href=")
427 (setf (link-href-end view) "xmllink")
428 (setf (link-ampersand view) "&"))
429 ((or :ie-xml-link :ie-xml-link-labels)
430 (initialize-xml-view view)
431 (setf (link-href-start view) "html:a href=")
432 (setf (link-href-end view) "html:a")
433 (setf (link-ampersand view) "&"))))
436 ;;;; *************************************************************************
437 ;;;; View Data Format Section
438 ;;;; *************************************************************************
440 (defun class-name-of (obj)
441 (string-downcase (class-name (class-of obj))))
443 (defvar +newline-string+ (format nil "~%"))
445 (defun write-user-name-maybe-plural (obj nitems strm)
448 (hyperobject-class-user-name-plural obj)
449 (hyperobject-class-user-name obj))
452 (defun initialize-text-view (view)
453 (setf (list-start-printer view)
455 (eval '(lambda (obj nitems indent strm)
456 (declare (ignore indent))
457 (write-user-name-maybe-plural obj nitems strm)
458 (write-char #\: strm)
459 (write-char #\Newline strm)))))
460 (setf (list-start-indent view) t)
461 (setf (obj-data-indent view) t)
462 (setf (obj-data-end-printer view) +newline-string+)
463 (setf (indenter view) #'indent-spaces))
465 (defun html-list-start-func (obj nitems indent strm)
466 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
467 (write-fixnum (+ indent indent) strm)
468 (write-string "em;\">" strm)
469 (write-user-name-maybe-plural obj nitems strm)
470 (write-string "</div>" strm)
471 (write-char #\newline strm)
472 (write-string "<ul>" strm)
473 (write-char #\newline strm))
475 (defun initialize-html-view (view)
476 (initialize-text-view view)
477 (setf (indenter view) #'indent-spaces)
478 (setf (file-start-str view) (format nil "<html><body>~%"))
479 (setf (file-end-str view) (format nil "</body><html>~%"))
480 (setf (list-start-indent view) t)
481 (setf (list-start-printer view) #'html-list-start-func)
482 (setf (list-end-printer view) (format nil "</ul>~%"))
483 (setf (list-end-indent view) t)
484 (setf (obj-start-indent view) nil)
485 (setf (obj-start-printer view) "<li>")
486 (setf (obj-end-indent view) nil)
487 (setf (obj-end-printer view) (format nil "</li>~%"))
488 (setf (obj-data-end-printer view) nil)
489 (setf (obj-data-indent view) nil))
491 (defun xhtml-list-start-func (obj nitems indent strm)
492 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
493 (write-fixnum (+ indent indent) strm)
494 (write-string "em;\">" strm)
495 (write-user-name-maybe-plural obj nitems strm)
496 (write-string "</div>" strm)
497 (write-string "<div style=\"margin-left:" strm)
498 (write-fixnum (+ indent indent) strm)
499 (write-string "em;\">" strm)
500 (write-char #\newline strm))
502 (defun table-list-start-func (obj nitems indent strm)
503 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
504 (write-fixnum (+ indent indent) strm)
505 (write-string "em;\">" strm)
506 (write-user-name-maybe-plural obj nitems strm)
507 (write-string "</div>" strm)
508 (write-char #\newline strm)
509 (write-string "<table style=\"margin-left:" strm)
510 (write-fixnum (+ indent indent) strm)
511 (write-string "em;\">" strm)
512 (write-string "<tbody>" strm)
513 (write-char #\newline strm))
515 (defun table-label-list-start-func (obj nitems indent strm)
516 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
517 (write-fixnum (+ indent indent) strm)
518 (write-string "em;\">" strm)
519 (write-user-name-maybe-plural obj nitems strm)
520 (write-string "</div>" strm)
521 (write-char #\newline strm)
522 (write-string "<table style=\"margin-left:" strm)
523 (write-fixnum (+ indent indent) strm)
524 (write-string "em;\">" strm)
525 (write-string "<thead>" strm)
526 (dolist (slot (default-print-slots (class-of obj)))
527 (write-string "<th>" strm)
528 (write-string (write-to-string slot) strm)
529 (write-string "</th>" strm))
530 (write-string "</thead>" strm)
531 (write-char #\newline strm)
532 (write-string "<tbody>" strm)
533 (write-char #\newline strm))
535 (defun html-obj-start (obj indent strm)
536 (declare (ignore obj indent))
537 (write-string "<div style=\"margin-left:2em;\">" strm))
539 (defun initialize-xhtml-view (view)
540 (initialize-text-view view)
541 (setf (indenter view) #'indent-spaces)
542 (setf (file-start-str view) (format nil "<html><body>~%"))
543 (setf (file-end-str view) (format nil "</body><html>~%"))
544 (setf (list-start-indent view) nil)
545 (setf (list-start-printer view) #'xhtml-list-start-func)
546 (setf (list-end-printer view) (format nil "</div>~%"))
547 (setf (list-end-indent view) nil)
548 (setf (obj-start-indent view) nil)
549 (setf (obj-start-printer view) #'html-obj-start)
550 (setf (obj-end-printer view) (format nil "</div>~%"))
551 (setf (obj-data-indent view) nil))
553 (defun initialize-table-view (view)
554 (initialize-text-view view)
555 (setf (indenter view) #'indent-spaces)
556 (setf (file-start-str view) (format nil "<html><body>~%"))
557 (setf (file-end-str view) (format nil "</body><html>~%"))
558 (setf (list-start-indent view) nil)
559 (setf (list-start-printer view) #'table-list-start-func)
560 (setf (list-end-printer view) (format nil "</tbody>~%</table>~%"))
561 (setf (list-end-indent view) nil)
562 (setf (obj-start-indent view) nil)
563 (setf (obj-start-printer view) #'html-obj-start)
564 (setf (obj-start-printer view) (format nil "<tr>"))
565 (setf (obj-end-printer view) (format nil "</tr>~%"))
566 (setf (obj-data-indent view) nil))
568 (defun xmlformat-list-end-func (x strm)
569 (write-string "</" strm)
570 (write-string (class-name-of x) strm)
571 (write-string "list" strm)
572 (write-string ">" strm)
573 (write-char #\newline strm))
575 (defun xmlformat-list-start-func (x nitems indent strm)
576 (declare (ignore indent))
577 (write-char #\< strm)
578 (write-string (class-name-of x) strm)
579 (write-string "list><title>" strm)
580 (write-user-name-maybe-plural x nitems strm)
581 (write-string ":</title>" strm)
582 (write-char #\newline strm))
584 (defun initialize-xml-view (view)
585 (let ((name (string-downcase (symbol-name (object-class view)))))
586 (setf (file-start-str view) "") ; (std-xml-header)
587 (setf (list-start-indent view) t)
588 (setf (list-start-printer view) #'xmlformat-list-start-func)
589 (setf (list-end-indent view) t)
590 (setf (list-end-printer view) #'xmlformat-list-end-func)
591 (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
592 (setf (obj-start-indent view) t)
593 (setf (obj-end-printer view) (format nil "</~(~a~)>~%" name))
594 (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
595 (setf (subobj-end-indent view) nil)
596 (setf (obj-data-indent view) nil)))
599 ;;; File Start and Ends
601 (defun fmt-file-start (view strm)
602 (awhen (file-start-str view)
603 (write-string it strm)))
605 (defun fmt-file-end (view strm)
606 (awhen (file-end-str view)
607 (write-string it strm)))
609 ;;; List Start and Ends
611 (defun fmt-list-start (obj view strm indent num-items)
612 (when (list-start-indent view)
613 (awhen (indenter view)
614 (funcall it indent strm)))
615 (awhen (list-start-printer view)
617 (write-string it strm)
618 (funcall it obj num-items indent strm))))
620 (defun fmt-list-end (obj view strm indent num-items)
621 (declare (ignore num-items))
622 (when (list-end-indent view)
623 (awhen (indenter view)
624 (funcall it indent strm)))
625 (awhen (list-end-printer view)
627 (write-string it strm)
628 (funcall it obj strm))))
630 ;;; Object Start and Ends
633 (defun fmt-obj-start (obj view strm indent)
634 (when (obj-start-indent view)
635 (awhen (indenter view)
636 (funcall it indent strm)))
637 (awhen (obj-start-printer view)
639 (write-string it strm)
640 (funcall it obj indent strm))))
642 (defun fmt-obj-end (obj view strm indent)
643 (when (obj-end-indent view)
644 (awhen (indenter view)
645 (funcall it indent strm)))
646 (awhen (obj-end-printer view)
648 (write-string it strm)
649 (funcall it obj strm))))
651 (defun fmt-subobj-start (obj view strm indent)
652 (when (subobj-start-indent view)
653 (awhen (indenter view)
654 (funcall it indent strm)))
655 (awhen (subobj-start-printer view)
657 (write-string it strm)
658 (funcall it obj indent strm))))
660 (defun fmt-subobj-end (obj view strm indent)
661 (when (subobj-end-indent view)
662 (awhen (indenter view)
663 (funcall it indent strm)))
664 (awhen (subobj-end-printer view)
666 (write-string it strm)
667 (funcall it obj strm))))
672 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
673 (with-output-to-string (s)
674 (write-string (link-href-start view) s)
676 (let ((link-page (link-page view)))
679 (write-string (make-url link-page) s)
680 (write-string "?func=" s)
681 (write-simple fieldfunc s)
682 (write-string (link-ampersand view) s)
683 (write-string "key=" s)
684 (write-simple fieldvalue s)
685 (dolist (var refvars)
686 (write-string (link-ampersand view) s)
687 (write-simple (car var) s)
689 (write-simple (cdr var) s)))
691 (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
694 (defun make-link-end (obj view fieldname)
695 (declare (ignore obj fieldname))
696 (link-href-end view))
698 (defun fmt-obj-data (obj view strm indent refvars link-printer)
699 (awhen (obj-data-start-printer view)
701 (write-string it strm)
702 (funcall it obj strm)))
703 (when (obj-data-indent view)
704 (awhen (indenter view)
705 (funcall it indent strm)))
706 (if (link-slots view)
707 (fmt-obj-data-with-link obj view strm refvars link-printer)
708 (fmt-obj-data-plain obj view strm))
709 (awhen (obj-data-end-printer view)
711 (write-string it strm)
712 (funcall it obj strm))))
714 (defun fmt-obj-data-plain (obj view strm)
715 (awhen (obj-data-printer view)
716 (funcall it obj strm nil)))
718 (defun fmt-obj-data-with-link (obj view strm refvars link-printer)
719 (let ((refvalues '()))
720 (declare (dynamic-extent refvalues))
721 ;; make list of hyperlink link fields for printing to refstr template
722 (dolist (name (link-slots view))
723 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
724 (push (make-link-start view (lookup it) (slot-value obj name)
725 (append (link-parameters it) refvars)
728 (push (make-link-end obj view name) refvalues)))
729 (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
731 (defun obj-data (obj view)
732 "Returns the objects data as a string. Used by common-graphics outline function"
733 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
735 ;;; Display method for objects
738 (defun load-all-subobjects (objs)
739 "Load all subobjects if they have not already been loaded."
740 (dolist (obj (mklist objs))
741 (dolist (subobj (hyperobject-class-subobjects obj))
742 (awhen (slot-value obj (name-slot subobj))
743 (load-all-subobjects it))))
746 (defun view-subobjects (obj strm &optional vid (indent 0) filter
747 subobjects refvars link-printer)
748 (when (hyperobject-class-subobjects obj)
749 (dolist (subobj (hyperobject-class-subobjects obj))
750 (aif (slot-value obj (name-slot subobj))
752 it (get-view-id (car (mklist it)) vid)
753 strm vid (1+ indent) filter subobjects refvars
757 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
758 subobjects refvars link-printer)
759 "Display a single or list of hyperobject-class instances and their subobjects"
760 (let-when (objlist (mklist objs))
761 (let ((nobjs (length objlist))
765 (*print-readably* nil)
768 (fmt-list-start (car objlist) view strm indent nobjs)
769 (dolist (obj objlist)
770 (awhen (printer view)
771 (funcall it obj strm))
772 (unless (and filter (not (funcall filter obj)))
773 (fmt-obj-start obj view strm indent)
774 (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
775 (fmt-obj-end obj view strm indent)
778 (fmt-subobj-start obj view strm indent)
779 (view-subobjects obj strm vid indent filter subobjects
780 refvars link-printer)
781 (fmt-subobj-end obj view strm indent))
782 (fmt-subobj-start obj view strm indent))))
783 (fmt-list-end (car objlist) view strm indent nobjs)))
787 (defun view (objs &key (stream *standard-output*) vid view
788 filter subobjects refvars file-wrapper link-printer)
789 "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
790 (let-when (objlist (mklist objs))
792 (setq view (get-view-id (car objlist) vid)))
794 (fmt-file-start view stream))
795 (view-hyperobject objlist view stream vid 0 filter subobjects refvars
798 (fmt-file-end view stream)))
804 (defun fmt-comma-integer (i)
805 (format nil "~:d" i))