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 'type))
286 (and (in vid :xml :xhtml :xml-link :xhtml-link
287 :xml-labels :ie-xml-labels
288 :xhtml-link-labels :xml-link-labels :ie-xml-link
291 (lisp-type-is-a-string type))))))
292 (hyperlink (esd-hyperlink slot)))
297 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
298 (:compact-text-labels
299 (vector-push-extend `(write-string ,user-name s) print-func)
300 (vector-push-extend '(write-char #\space s) print-func)
302 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
304 (ppfc-html user-name name type formatter cdata print-func))
306 (ppfc-xml xml-tag name type formatter cdata print-func))
308 (ppfc-html-labels user-name name type formatter cdata print-func))
310 (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
311 ((:display-table :display-table-labels)
312 (ppfc-display-table user-name name type formatter cdata print-func))
314 (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
315 ((or :html-link :xhtml-link)
317 (ppfc-html-link name type formatter cdata nlink print-func)
318 (ppfc-html user-name name type formatter cdata print-func)))
319 ((or :xml-link :ie-xml-link)
321 (ppfc-html-link name type formatter cdata nlink print-func)
322 (ppfc-xml xml-tag name type formatter cdata print-func)))
325 (ppfc-html-link-labels user-name name type formatter cdata nlink
327 (ppfc-html-labels user-name name type formatter cdata print-func)))
330 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
332 (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
334 ((or :xml-link-labels :ie-xml-link-labels)
336 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
338 (ppfc-xml-labels xml-tag user-name name type formatter cdata
342 (defun view-has-links-p (view)
343 (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link
344 :html-link-labels :xhtml-link-labels :xml-link-labels
345 :ie-xml-link-labels))
347 (defun creatable-view-id-p (obj-cl vid)
348 "Returns T if a view id can be created for this class"
349 (declare (ignore obj-cl))
350 (in vid :compact-text :compact-text-labels
351 :html :html-labels :html-link-labels
352 :xhtml :xhtml-labels :xhtml-link-labels
353 :xhtml-link :html-link
354 :xml :xml-labels :xml-link :ie-xml-link
355 :xml-link-labels :ie-xml-link-labels
356 :display-table :display-table-labels :edit-table :edit-table-labels))
358 (defun initialize-view-by-id (obj-cl view)
359 "Initialize a view based upon a preset vid"
360 (unless (creatable-view-id-p obj-cl (id view))
361 (error "Unable to automatically create view id ~A" (id view)))
363 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
366 (print-func (make-array 10 :fill-pointer 0 :adjustable t)))
368 (do* ((slots (slots view) (cdr slots))
369 (slot-name (car slots) (car slots))
370 (slot (find-slot-by-name obj-cl slot-name)
371 (find-slot-by-name obj-cl slot-name)))
374 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
376 (push-print-fun-code (id view) slot (length links) print-func)
377 (when (> (length slots) 1)
378 (vector-push-extend '(write-char #\space s) print-func))
380 (when (and (view-has-links-p view) (esd-hyperlink slot))
381 (push (slot-definition-name slot) links)))
383 (vector-push-extend 'x print-func) ;; return object
384 (setf (obj-data-print-code view) `(lambda (x s links)
385 (declare (ignorable s links))
386 ,@(map 'list #'identity print-func)))
387 (setf (obj-data-printer view)
388 (compile nil (eval (obj-data-print-code view))))
390 (setf (link-slots view) (nreverse links)))
392 (finalize-view-by-id view)
395 (defun finalize-view-by-id (view)
397 ((or :compact-text :compact-text-labels)
398 (initialize-text-view view))
399 ((or :html :html-labels)
400 (initialize-html-view view))
401 ((or :xhtml :xhtml-labels)
402 (initialize-xhtml-view view))
403 ((or :xml :xml-labels)
404 (initialize-xml-view view))
405 ((or :html-link :html-link-labels)
406 (initialize-html-view view)
407 (setf (link-href-start view) "a href=")
408 (setf (link-href-end view) "a")
409 (setf (link-ampersand view) "&"))
410 ((or :xhtml-link :xhtml-link-labels)
411 (initialize-xhtml-view view)
412 (setf (link-href-start view) "a href=")
413 (setf (link-href-end view) "a")
414 (setf (link-ampersand view) "&"))
415 ((or :display-table :display-table-labels :edit-tables)
416 (initialize-table-view view)
417 (when (in (id view) :display-table-labels :edit-table-labels)
418 (setf (list-start-printer view) #'table-label-list-start-func))
419 (setf (link-href-start view) "a href=")
420 (setf (link-href-end view) "a")
421 (setf (link-ampersand view) "&"))
422 ((or :xml-link :xml-link-labels)
423 (initialize-xml-view view)
424 (setf (link-href-start view)
425 "xmllink xlink:type=\"simple\" xlink:href=")
426 (setf (link-href-end view) "xmllink")
427 (setf (link-ampersand view) "&"))
428 ((or :ie-xml-link :ie-xml-link-labels)
429 (initialize-xml-view view)
430 (setf (link-href-start view) "html:a href=")
431 (setf (link-href-end view) "html:a")
432 (setf (link-ampersand view) "&"))))
435 ;;;; *************************************************************************
436 ;;;; View Data Format Section
437 ;;;; *************************************************************************
439 (defun class-name-of (obj)
440 (string-downcase (class-name (class-of obj))))
442 (defvar +newline-string+ (format nil "~%"))
444 (defun write-user-name-maybe-plural (obj nitems strm)
447 (hyperobject-class-user-name-plural obj)
448 (hyperobject-class-user-name obj))
451 (defun initialize-text-view (view)
452 (setf (list-start-printer view)
454 (eval '(lambda (obj nitems indent strm)
455 (declare (ignore indent))
456 (write-user-name-maybe-plural obj nitems strm)
457 (write-char #\: strm)
458 (write-char #\Newline strm)))))
459 (setf (list-start-indent view) t)
460 (setf (obj-data-indent view) t)
461 (setf (obj-data-end-printer view) +newline-string+)
462 (setf (indenter view) #'indent-spaces))
464 (defun html-list-start-func (obj nitems indent strm)
465 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
466 (write-fixnum (+ indent indent) strm)
467 (write-string "em;\">" strm)
468 (write-user-name-maybe-plural obj nitems strm)
469 (write-string "</div>" strm)
470 (write-char #\newline strm)
471 (write-string "<ul>" strm)
472 (write-char #\newline strm))
474 (defun initialize-html-view (view)
475 (initialize-text-view view)
476 (setf (indenter view) #'indent-spaces)
477 (setf (file-start-str view) (format nil "<html><body>~%"))
478 (setf (file-end-str view) (format nil "</body><html>~%"))
479 (setf (list-start-indent view) t)
480 (setf (list-start-printer view) #'html-list-start-func)
481 (setf (list-end-printer view) (format nil "</ul>~%"))
482 (setf (list-end-indent view) t)
483 (setf (obj-start-indent view) nil)
484 (setf (obj-start-printer view) "<li>")
485 (setf (obj-end-indent view) nil)
486 (setf (obj-end-printer view) (format nil "</li>~%"))
487 (setf (obj-data-end-printer view) nil)
488 (setf (obj-data-indent view) nil))
490 (defun xhtml-list-start-func (obj nitems indent strm)
491 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
492 (write-fixnum (+ indent indent) strm)
493 (write-string "em;\">" strm)
494 (write-user-name-maybe-plural obj nitems strm)
495 (write-string "</div>" strm)
496 (write-string "<div style=\"margin-left:" strm)
497 (write-fixnum (+ indent indent) strm)
498 (write-string "em;\">" strm)
499 (write-char #\newline strm))
501 (defun table-list-start-func (obj nitems indent strm)
502 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
503 (write-fixnum (+ indent indent) strm)
504 (write-string "em;\">" strm)
505 (write-user-name-maybe-plural obj nitems strm)
506 (write-string "</div>" strm)
507 (write-char #\newline strm)
508 (write-string "<table style=\"margin-left:" strm)
509 (write-fixnum (+ indent indent) strm)
510 (write-string "em;\">" strm)
511 (write-string "<tbody>" strm)
512 (write-char #\newline strm))
514 (defun table-label-list-start-func (obj nitems indent strm)
515 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
516 (write-fixnum (+ indent indent) strm)
517 (write-string "em;\">" strm)
518 (write-user-name-maybe-plural obj nitems strm)
519 (write-string "</div>" strm)
520 (write-char #\newline strm)
521 (write-string "<table style=\"margin-left:" strm)
522 (write-fixnum (+ indent indent) strm)
523 (write-string "em;\">" strm)
524 (write-string "<thead>" strm)
525 (dolist (slot (default-print-slots (class-of obj)))
526 (write-string "<th>" strm)
527 (write-string (write-to-string slot) strm)
528 (write-string "</th>" strm))
529 (write-string "</thead>" strm)
530 (write-char #\newline strm)
531 (write-string "<tbody>" strm)
532 (write-char #\newline strm))
534 (defun html-obj-start (obj indent strm)
535 (declare (ignore obj indent))
536 (write-string "<div style=\"margin-left:2em;\">" strm))
538 (defun initialize-xhtml-view (view)
539 (initialize-text-view view)
540 (setf (indenter view) #'indent-spaces)
541 (setf (file-start-str view) (format nil "<html><body>~%"))
542 (setf (file-end-str view) (format nil "</body><html>~%"))
543 (setf (list-start-indent view) nil)
544 (setf (list-start-printer view) #'xhtml-list-start-func)
545 (setf (list-end-printer view) (format nil "</div>~%"))
546 (setf (list-end-indent view) nil)
547 (setf (obj-start-indent view) nil)
548 (setf (obj-start-printer view) #'html-obj-start)
549 (setf (obj-end-printer view) (format nil "</div>~%"))
550 (setf (obj-data-indent view) nil))
552 (defun initialize-table-view (view)
553 (initialize-text-view view)
554 (setf (indenter view) #'indent-spaces)
555 (setf (file-start-str view) (format nil "<html><body>~%"))
556 (setf (file-end-str view) (format nil "</body><html>~%"))
557 (setf (list-start-indent view) nil)
558 (setf (list-start-printer view) #'table-list-start-func)
559 (setf (list-end-printer view) (format nil "</tbody>~%</table>~%"))
560 (setf (list-end-indent view) nil)
561 (setf (obj-start-indent view) nil)
562 (setf (obj-start-printer view) #'html-obj-start)
563 (setf (obj-start-printer view) (format nil "<tr>"))
564 (setf (obj-end-printer view) (format nil "</tr>~%"))
565 (setf (obj-data-indent view) nil))
567 (defun xmlformat-list-end-func (x strm)
568 (write-string "</" strm)
569 (write-string (class-name-of x) strm)
570 (write-string "list" strm)
571 (write-string ">" strm)
572 (write-char #\newline strm))
574 (defun xmlformat-list-start-func (x nitems indent strm)
575 (declare (ignore indent))
576 (write-char #\< strm)
577 (write-string (class-name-of x) strm)
578 (write-string "list><title>" strm)
579 (write-user-name-maybe-plural x nitems strm)
580 (write-string ":</title>" strm)
581 (write-char #\newline strm))
583 (defun initialize-xml-view (view)
584 (let ((name (string-downcase (symbol-name (object-class view)))))
585 (setf (file-start-str view) "") ; (std-xml-header)
586 (setf (list-start-indent view) t)
587 (setf (list-start-printer view) #'xmlformat-list-start-func)
588 (setf (list-end-indent view) t)
589 (setf (list-end-printer view) #'xmlformat-list-end-func)
590 (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
591 (setf (obj-start-indent view) t)
592 (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
593 (setf (subobj-end-indent view) nil)
594 (setf (obj-data-indent view) nil)))
597 ;;; File Start and Ends
599 (defun fmt-file-start (view strm)
600 (awhen (file-start-str view)
601 (write-string it strm)))
603 (defun fmt-file-end (view strm)
604 (awhen (file-end-str view)
605 (write-string it strm)))
607 ;;; List Start and Ends
609 (defun fmt-list-start (obj view strm indent num-items)
610 (when (list-start-indent view)
611 (awhen (indenter view)
612 (funcall it indent strm)))
613 (awhen (list-start-printer view)
615 (write-string it strm)
616 (funcall it obj num-items indent strm))))
618 (defun fmt-list-end (obj view strm indent num-items)
619 (declare (ignore num-items))
620 (when (list-end-indent view)
621 (awhen (indenter view)
622 (funcall it indent strm)))
623 (awhen (list-end-printer view)
625 (write-string it strm)
626 (funcall it obj strm))))
628 ;;; Object Start and Ends
631 (defun fmt-obj-start (obj view strm indent)
632 (when (obj-start-indent view)
633 (awhen (indenter view)
634 (funcall it indent strm)))
635 (awhen (obj-start-printer view)
637 (write-string it strm)
638 (funcall it obj indent strm))))
640 (defun fmt-obj-end (obj view strm indent)
641 (when (obj-end-indent view)
642 (awhen (indenter view)
643 (funcall it indent strm)))
644 (awhen (obj-end-printer view)
646 (write-string it strm)
647 (funcall it obj strm))))
649 (defun fmt-subobj-start (obj view strm indent)
650 (when (subobj-start-indent view)
651 (awhen (indenter view)
652 (funcall it indent strm)))
653 (awhen (subobj-start-printer view)
655 (write-string it strm)
656 (funcall it obj indent strm))))
658 (defun fmt-subobj-end (obj view strm indent)
659 (when (subobj-end-indent view)
660 (awhen (indenter view)
661 (funcall it indent strm)))
662 (awhen (subobj-end-printer view)
664 (write-string it strm)
665 (funcall it obj strm))))
670 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
671 (with-output-to-string (s)
672 (write-string (link-href-start view) s)
674 (let ((link-page (link-page view)))
677 (write-string (make-url link-page) s)
678 (write-string "?func=" s)
679 (write-simple fieldfunc s)
680 (write-string (link-ampersand view) s)
681 (write-string "key=" s)
682 (write-simple fieldvalue s)
683 (dolist (var refvars)
684 (write-string (link-ampersand view) s)
685 (write-simple (car var) s)
687 (write-simple (cdr var) s)))
689 (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
692 (defun make-link-end (obj view fieldname)
693 (declare (ignore obj fieldname))
694 (link-href-end view))
696 (defun fmt-obj-data (obj view strm indent refvars link-printer)
697 (awhen (obj-data-start-printer view)
699 (write-string it strm)
700 (funcall it obj strm)))
701 (when (obj-data-indent view)
702 (awhen (indenter view)
703 (funcall it indent strm)))
704 (if (link-slots view)
705 (fmt-obj-data-with-link obj view strm refvars link-printer)
706 (fmt-obj-data-plain obj view strm))
707 (awhen (obj-data-end-printer view)
709 (write-string it strm)
710 (funcall it obj strm))))
712 (defun fmt-obj-data-plain (obj view strm)
713 (awhen (obj-data-printer view)
714 (funcall it obj strm nil)))
716 (defun fmt-obj-data-with-link (obj view strm refvars link-printer)
717 (let ((refvalues '()))
718 (declare (dynamic-extent refvalues))
719 ;; make list of hyperlink link fields for printing to refstr template
720 (dolist (name (link-slots view))
721 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
722 (push (make-link-start view (lookup it) (slot-value obj name)
723 (append (link-parameters it) refvars)
726 (push (make-link-end obj view name) refvalues)))
727 (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
729 (defun obj-data (obj view)
730 "Returns the objects data as a string. Used by common-graphics outline function"
731 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
733 ;;; Display method for objects
736 (defun load-all-subobjects (objs)
737 "Load all subobjects if they have not already been loaded."
738 (dolist (obj (mklist objs))
739 (dolist (subobj (hyperobject-class-subobjects obj))
740 (awhen (slot-value obj (name-slot subobj))
741 (load-all-subobjects it))))
744 (defun view-subobjects (obj strm &optional vid (indent 0) filter
745 subobjects refvars link-printer)
746 (when (hyperobject-class-subobjects obj)
747 (dolist (subobj (hyperobject-class-subobjects obj))
748 (aif (slot-value obj (name-slot subobj))
750 it (get-view-id (car (mklist it)) vid)
751 strm vid (1+ indent) filter subobjects refvars
755 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
756 subobjects refvars link-printer)
757 "Display a single or list of hyperobject-class instances and their subobjects"
758 (let-when (objlist (mklist objs))
759 (let ((nobjs (length objlist))
763 (*print-readably* nil)
766 (fmt-list-start (car objlist) view strm indent nobjs)
767 (dolist (obj objlist)
768 (awhen (printer view)
769 (funcall it obj strm))
770 (unless (and filter (not (funcall filter obj)))
771 (fmt-obj-start obj view strm indent)
772 (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
773 (fmt-obj-end obj view strm indent)
775 (fmt-subobj-start obj view strm indent)
776 (view-subobjects obj strm vid indent filter subobjects
777 refvars link-printer)
778 (fmt-subobj-end obj view strm indent))))
779 (fmt-list-end (car objlist) view strm indent nobjs)))
783 (defun view (objs &key (stream *standard-output*) vid view
784 filter subobjects refvars file-wrapper link-printer)
785 "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
786 (let-when (objlist (mklist objs))
788 (setq view (get-view-id (car objlist) vid)))
790 (fmt-file-start view stream))
791 (view-hyperobject objlist view stream vid 0 filter subobjects refvars
794 (fmt-file-end view stream)))
800 (defun fmt-comma-integer (i)
801 (format nil "~:d" i))