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 list 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 (declare (ignore initargs))
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-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-display-table (title name type formatter cdata print-func)
241 (vector-push-extend '(write-string "<td>" s) print-func)
242 (ppfc-html title name type formatter cdata print-func)
243 (vector-push-extend '(write-string "</td>" s) print-func))
245 (defun ppfc-html-labels (label name type formatter cdata print-func)
246 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
247 (vector-push-extend `(write-string ,label s) print-func)
248 (vector-push-extend '(write-string "</span> " s) print-func)
249 (ppfc-html label name type formatter cdata print-func))
251 (defun ppfc-xhtml-labels (label tag name type formatter cdata print-func)
252 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
253 (vector-push-extend `(write-string ,label s) print-func)
254 (vector-push-extend '(write-string "</span> " s) print-func)
255 (ppfc-html tag name type formatter cdata print-func))
257 (defun ppfc-xml-labels (label tag name type formatter cdata print-func)
258 (vector-push-extend '(write-string "<label>" s) print-func)
259 (vector-push-extend `(write-string ,label s) print-func)
260 (vector-push-extend '(write-string "</label> " s) print-func)
261 (ppfc-xml tag name type formatter cdata print-func))
263 (defun ppfc-html-link (name type formatter cdata nlink print-func)
264 (declare (fixnum nlink))
265 (vector-push-extend '(write-char #\< s) print-func)
266 (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func)
267 (vector-push-extend '(write-char #\> s) print-func)
268 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
269 (vector-push-extend '(write-string "</" s) print-func)
270 (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func)
271 (vector-push-extend '(write-char #\> s) print-func))
273 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
274 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
275 (vector-push-extend `(write-string ,label s) print-func)
276 (vector-push-extend '(write-string "</span> " s) print-func)
277 (ppfc-html-link name type formatter cdata nlink print-func))
279 (defun push-print-fun-code (vid slot nlink print-func)
280 (let* ((formatter (esd-print-formatter slot))
281 (name (slot-definition-name slot))
282 (user-name (esd-user-name slot))
283 (xml-user-name (escape-xml-string user-name))
284 (xml-tag (escape-xml-string user-name))
285 (type (slot-definition-type slot))
288 (and (in vid :xml :xhtml :xml-link :xhtml-link
289 :xml-labels :ie-xml-labels
290 :xhtml-link-labels :xml-link-labels :ie-xml-link
293 (lisp-type-is-a-string type))))))
294 (hyperlink (esd-hyperlink slot)))
299 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
300 (:compact-text-labels
301 (vector-push-extend `(write-string ,user-name s) print-func)
302 (vector-push-extend '(write-char #\space s) print-func)
304 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
306 (ppfc-html user-name name type formatter cdata print-func))
308 (ppfc-xml xml-tag name type formatter cdata print-func))
310 (ppfc-html-labels user-name name type formatter cdata print-func))
312 (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
313 ((:display-table :display-table-labels)
314 (ppfc-display-table user-name name type formatter cdata print-func))
316 (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
317 ((or :html-link :xhtml-link)
319 (ppfc-html-link name type formatter cdata nlink print-func)
320 (ppfc-html user-name name type formatter cdata print-func)))
321 ((or :xml-link :ie-xml-link)
323 (ppfc-html-link name type formatter cdata nlink print-func)
324 (ppfc-xml xml-tag name type formatter cdata print-func)))
327 (ppfc-html-link-labels user-name name type formatter cdata nlink
329 (ppfc-html-labels user-name name type formatter cdata print-func)))
332 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
334 (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
336 ((or :xml-link-labels :ie-xml-link-labels)
338 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
340 (ppfc-xml-labels xml-tag user-name name type formatter cdata
344 (defun view-has-links-p (view)
345 (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link
346 :html-link-labels :xhtml-link-labels :xml-link-labels
347 :ie-xml-link-labels))
349 (defun creatable-view-id-p (obj-cl vid)
350 "Returns T if a view id can be created for this class"
351 (declare (ignore obj-cl))
352 (in vid :compact-text :compact-text-labels
353 :html :html-labels :html-link-labels
354 :xhtml :xhtml-labels :xhtml-link-labels
355 :xhtml-link :html-link
356 :xml :xml-labels :xml-link :ie-xml-link
357 :xml-link-labels :ie-xml-link-labels
358 :display-table :display-table-labels :edit-table :edit-table-labels))
360 (defun initialize-view-by-id (obj-cl view)
361 "Initialize a view based upon a preset vid"
362 (unless (creatable-view-id-p obj-cl (id view))
363 (error "Unable to automatically create view id ~A" (id view)))
365 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
368 (print-func (make-array 20 :fill-pointer 0 :adjustable t)))
370 (do* ((slots (slots view) (cdr slots))
371 (slot-name (car slots) (car slots))
372 (slot (find-slot-by-name obj-cl slot-name)
373 (find-slot-by-name obj-cl slot-name)))
376 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
378 (push-print-fun-code (id view) slot (length links) print-func)
379 (when (> (length slots) 1)
380 (vector-push-extend '(write-char #\space s) print-func))
382 (when (and (view-has-links-p view) (esd-hyperlink slot))
383 (push (slot-definition-name slot) links)))
385 (vector-push-extend 'x print-func) ;; return object
386 (setf (obj-data-print-code view) `(lambda (x s links)
387 (declare (ignorable s links))
388 ,@(map 'list #'identity print-func)))
389 (setf (obj-data-printer view)
390 (compile nil (eval (obj-data-print-code view))))
392 (setf (link-slots view) (nreverse links)))
394 (finalize-view-by-id view)
397 (defun finalize-view-by-id (view)
399 ((or :compact-text :compact-text-labels)
400 (initialize-text-view view))
401 ((or :html :html-labels)
402 (initialize-html-view view))
403 ((or :xhtml :xhtml-labels)
404 (initialize-xhtml-view view))
405 ((or :xml :xml-labels)
406 (initialize-xml-view view))
407 ((or :html-link :html-link-labels)
408 (initialize-html-view view)
409 (setf (link-href-start view) "a href=")
410 (setf (link-href-end view) "a")
411 (setf (link-ampersand view) "&"))
412 ((or :xhtml-link :xhtml-link-labels)
413 (initialize-xhtml-view view)
414 (setf (link-href-start view) "a href=")
415 (setf (link-href-end view) "a")
416 (setf (link-ampersand view) "&"))
417 ((or :display-table :display-table-labels :edit-tables)
418 (initialize-table-view view)
419 (when (in (id view) :display-table-labels :edit-table-labels)
420 (setf (list-start-printer view) #'table-label-list-start-func))
421 (setf (link-href-start view) "a href=")
422 (setf (link-href-end view) "a")
423 (setf (link-ampersand view) "&"))
424 ((or :xml-link :xml-link-labels)
425 (initialize-xml-view view)
426 (setf (link-href-start view)
427 "xmllink xlink:type=\"simple\" xlink:href=")
428 (setf (link-href-end view) "xmllink")
429 (setf (link-ampersand view) "&"))
430 ((or :ie-xml-link :ie-xml-link-labels)
431 (initialize-xml-view view)
432 (setf (link-href-start view) "html:a href=")
433 (setf (link-href-end view) "html:a")
434 (setf (link-ampersand view) "&"))))
437 ;;;; *************************************************************************
438 ;;;; View Data Format Section
439 ;;;; *************************************************************************
441 (defun class-name-of (obj)
442 (string-downcase (class-name (class-of obj))))
444 (defvar +newline-string+ (format nil "~%"))
446 (defun write-user-name-maybe-plural (obj nitems strm)
449 (hyperobject-class-user-name-plural obj)
450 (hyperobject-class-user-name obj))
453 (defun initialize-text-view (view)
454 (setf (list-start-printer view)
456 (eval '(lambda (obj nitems indent strm)
457 (declare (ignore indent))
458 (write-user-name-maybe-plural obj nitems strm)
459 (write-char #\: strm)
460 (write-char #\Newline strm)))))
461 (setf (list-start-indent view) t)
462 (setf (obj-data-indent view) t)
463 (setf (obj-data-end-printer view) +newline-string+)
464 (setf (indenter view) #'indent-spaces))
466 (defun html-list-start-func (obj nitems indent strm)
467 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
468 (write-fixnum (+ indent indent) strm)
469 (write-string "em;\">" strm)
470 (write-user-name-maybe-plural obj nitems strm)
471 (write-string "</div>" strm)
472 (write-char #\newline strm)
473 (write-string "<ul>" strm)
474 (write-char #\newline strm))
476 (defun initialize-html-view (view)
477 (initialize-text-view view)
478 (setf (indenter view) #'indent-spaces)
479 (setf (file-start-str view) (format nil "<html><body>~%"))
480 (setf (file-end-str view) (format nil "</body><html>~%"))
481 (setf (list-start-indent view) t)
482 (setf (list-start-printer view) #'html-list-start-func)
483 (setf (list-end-printer view) (format nil "</ul>~%"))
484 (setf (list-end-indent view) t)
485 (setf (obj-start-indent view) nil)
486 (setf (obj-start-printer view) "<li>")
487 (setf (obj-end-indent view) nil)
488 (setf (obj-end-printer view) (format nil "</li>~%"))
489 (setf (obj-data-end-printer view) nil)
490 (setf (obj-data-indent view) nil))
492 (defun xhtml-list-start-func (obj nitems indent strm)
493 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
494 (write-fixnum (+ indent indent) strm)
495 (write-string "em;\">" strm)
496 (write-user-name-maybe-plural obj nitems strm)
497 (write-string "</div>" strm)
498 (write-string "<div style=\"margin-left:" strm)
499 (write-fixnum (+ indent indent) strm)
500 (write-string "em;\">" strm)
501 (write-char #\newline strm))
503 (defun table-list-start-func (obj nitems indent strm)
504 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
505 (write-fixnum (+ indent indent) strm)
506 (write-string "em;\">" strm)
507 (write-user-name-maybe-plural obj nitems strm)
508 (write-string "</div>" strm)
509 (write-char #\newline strm)
510 (write-string "<table style=\"margin-left:" strm)
511 (write-fixnum (+ indent indent) strm)
512 (write-string "em;\">" strm)
513 (write-string "<tbody>" strm)
514 (write-char #\newline strm))
516 (defun table-label-list-start-func (obj nitems indent strm)
517 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
518 (write-fixnum (+ indent indent) strm)
519 (write-string "em;\">" strm)
520 (write-user-name-maybe-plural obj nitems strm)
521 (write-string "</div>" strm)
522 (write-char #\newline strm)
523 (write-string "<table style=\"margin-left:" strm)
524 (write-fixnum (+ indent indent) strm)
525 (write-string "em;\">" strm)
526 (write-string "<thead>" strm)
527 (dolist (slot (default-print-slots (class-of obj)))
528 (write-string "<th>" strm)
529 (write-string (write-to-string slot) strm)
530 (write-string "</th>" strm))
531 (write-string "</thead>" strm)
532 (write-char #\newline strm)
533 (write-string "<tbody>" strm)
534 (write-char #\newline strm))
536 (defun html-obj-start (obj indent strm)
537 (declare (ignore obj indent))
538 (write-string "<div style=\"margin-left:2em;\">" strm))
540 (defun initialize-xhtml-view (view)
541 (initialize-text-view view)
542 (setf (indenter view) #'indent-spaces)
543 (setf (file-start-str view) (format nil "<html><body>~%"))
544 (setf (file-end-str view) (format nil "</body><html>~%"))
545 (setf (list-start-indent view) nil)
546 (setf (list-start-printer view) #'xhtml-list-start-func)
547 (setf (list-end-printer view) (format nil "</div>~%"))
548 (setf (list-end-indent view) nil)
549 (setf (obj-start-indent view) nil)
550 (setf (obj-start-printer view) #'html-obj-start)
551 (setf (obj-end-printer view) (format nil "</div>~%"))
552 (setf (obj-data-indent view) nil))
554 (defun initialize-table-view (view)
555 (initialize-text-view view)
556 (setf (indenter view) #'indent-spaces)
557 (setf (file-start-str view) (format nil "<html><body>~%"))
558 (setf (file-end-str view) (format nil "</body><html>~%"))
559 (setf (list-start-indent view) nil)
560 (setf (list-start-printer view) #'table-list-start-func)
561 (setf (list-end-printer view) (format nil "</tbody>~%</table>~%"))
562 (setf (list-end-indent view) nil)
563 (setf (obj-start-indent view) nil)
564 (setf (obj-start-printer view) #'html-obj-start)
565 (setf (obj-start-printer view) (format nil "<tr>"))
566 (setf (obj-end-printer view) (format nil "</tr>~%"))
567 (setf (obj-data-indent view) nil))
569 (defun xmlformat-list-end-func (x strm)
570 (write-string "</" strm)
571 (write-string (class-name-of x) strm)
572 (write-string "list" strm)
573 (write-string ">" strm)
574 (write-char #\newline strm))
576 (defun xmlformat-list-start-func (x nitems indent strm)
577 (declare (ignore indent))
578 (write-char #\< strm)
579 (write-string (class-name-of x) strm)
580 (write-string "list><title>" strm)
581 (write-user-name-maybe-plural x nitems strm)
582 (write-string ":</title>" strm)
583 (write-char #\newline strm))
585 (defun initialize-xml-view (view)
586 (let ((name (string-downcase (symbol-name (object-class view)))))
587 (setf (file-start-str view) "") ; (std-xml-header)
588 (setf (list-start-indent view) t)
589 (setf (list-start-printer view) #'xmlformat-list-start-func)
590 (setf (list-end-indent view) t)
591 (setf (list-end-printer view) #'xmlformat-list-end-func)
592 (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
593 (setf (obj-start-indent view) t)
594 (setf (obj-end-printer view) (format nil "</~(~a~)>~%" name))
595 (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
596 (setf (subobj-end-indent view) nil)
597 (setf (obj-data-indent view) nil)))
600 ;;; File Start and Ends
602 (defun fmt-file-start (view strm)
603 (awhen (file-start-str view)
604 (write-string it strm)))
606 (defun fmt-file-end (view strm)
607 (awhen (file-end-str view)
608 (write-string it strm)))
610 ;;; List Start and Ends
612 (defun fmt-list-start (obj view strm indent num-items)
613 (when (list-start-indent view)
614 (awhen (indenter view)
615 (funcall it indent strm)))
616 (awhen (list-start-printer view)
618 (write-string it strm)
619 (funcall it obj num-items indent strm))))
621 (defun fmt-list-end (obj view strm indent num-items)
622 (declare (ignore num-items))
623 (when (list-end-indent view)
624 (awhen (indenter view)
625 (funcall it indent strm)))
626 (awhen (list-end-printer view)
628 (write-string it strm)
629 (funcall it obj strm))))
631 ;;; Object Start and Ends
634 (defun fmt-obj-start (obj view strm indent)
635 (when (obj-start-indent view)
636 (awhen (indenter view)
637 (funcall it indent strm)))
638 (awhen (obj-start-printer view)
640 (write-string it strm)
641 (funcall it obj indent strm))))
643 (defun fmt-obj-end (obj view strm indent)
644 (when (obj-end-indent view)
645 (awhen (indenter view)
646 (funcall it indent strm)))
647 (awhen (obj-end-printer view)
649 (write-string it strm)
650 (funcall it obj strm))))
652 (defun fmt-subobj-start (obj view strm indent)
653 (when (subobj-start-indent view)
654 (awhen (indenter view)
655 (funcall it indent strm)))
656 (awhen (subobj-start-printer view)
658 (write-string it strm)
659 (funcall it obj indent strm))))
661 (defun fmt-subobj-end (obj view strm indent)
662 (when (subobj-end-indent view)
663 (awhen (indenter view)
664 (funcall it indent strm)))
665 (awhen (subobj-end-printer view)
667 (write-string it strm)
668 (funcall it obj strm))))
673 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
674 (with-output-to-string (s)
675 (write-string (link-href-start view) s)
677 (let ((link-page (link-page view)))
680 (write-string (make-url link-page) s)
681 (write-string "?func=" s)
682 (write-simple fieldfunc s)
683 (write-string (link-ampersand view) s)
684 (write-string "key=" s)
685 (write-simple fieldvalue s)
686 (dolist (var refvars)
687 (write-string (link-ampersand view) s)
688 (write-simple (car var) s)
690 (write-simple (cdr var) s)))
692 (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
695 (defun make-link-end (obj view fieldname)
696 (declare (ignore obj fieldname))
697 (link-href-end view))
699 (defun fmt-obj-data (obj view strm indent refvars link-printer)
700 (awhen (obj-data-start-printer view)
702 (write-string it strm)
703 (funcall it obj strm)))
704 (when (obj-data-indent view)
705 (awhen (indenter view)
706 (funcall it indent strm)))
707 (if (link-slots view)
708 (fmt-obj-data-with-link obj view strm refvars link-printer)
709 (fmt-obj-data-plain obj view strm))
710 (awhen (obj-data-end-printer view)
712 (write-string it strm)
713 (funcall it obj strm))))
715 (defun fmt-obj-data-plain (obj view strm)
716 (awhen (obj-data-printer view)
717 (funcall it obj strm nil)))
719 (defun fmt-obj-data-with-link (obj view strm refvars link-printer)
720 (let ((refvalues '()))
721 (declare (dynamic-extent refvalues))
722 ;; make list of hyperlink link fields for printing to refstr template
723 (dolist (name (link-slots view))
724 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
725 (push (make-link-start view (lookup it) (slot-value obj name)
726 (append (link-parameters it) refvars)
729 (push (make-link-end obj view name) refvalues)))
730 (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
732 (defun obj-data (obj view)
733 "Returns the objects data as a string. Used by common-graphics outline function"
734 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
736 ;;; Display method for objects
739 (defun load-all-subobjects (objs)
740 "Load all subobjects if they have not already been loaded."
741 (dolist (obj (mklist objs))
742 (dolist (subobj (hyperobject-class-subobjects obj))
743 (awhen (slot-value obj (name-slot subobj))
744 (load-all-subobjects it))))
747 (defun view-subobjects (obj strm &optional vid (indent 0) filter
748 subobjects refvars link-printer)
749 (when (hyperobject-class-subobjects obj)
750 (dolist (subobj (hyperobject-class-subobjects obj))
751 (aif (slot-value obj (name-slot subobj))
753 it (get-view-id (car (mklist it)) vid)
754 strm vid (1+ indent) filter subobjects refvars
758 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
759 subobjects refvars link-printer)
760 "Display a single or list of hyperobject-class instances and their subobjects"
761 (let-when (objlist (mklist objs))
762 (let ((nobjs (length objlist))
766 (*print-readably* nil)
769 (fmt-list-start (car objlist) view strm indent nobjs)
770 (dolist (obj objlist)
771 (awhen (printer view)
772 (funcall it obj strm))
773 (unless (and filter (not (funcall filter obj)))
774 (fmt-obj-start obj view strm indent)
775 (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
776 (fmt-obj-end obj view strm indent)
779 (fmt-subobj-start obj view strm indent)
780 (view-subobjects obj strm vid indent filter subobjects
781 refvars link-printer)
782 (fmt-subobj-end obj view strm indent))
783 (fmt-subobj-start obj view strm indent))))
784 (fmt-list-end (car objlist) view strm indent nobjs)))
788 (defun view (objs &key (stream *standard-output*) vid view
789 filter subobjects refvars file-wrapper link-printer)
790 "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
791 (let-when (objlist (mklist objs))
793 (setq view (get-view-id (car objlist) vid)))
795 (fmt-file-start view stream))
796 (view-hyperobject objlist view stream vid 0 filter subobjects refvars
799 (fmt-file-end view stream)))
805 (defun fmt-comma-integer (i)
806 (format nil "~:d" i))