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 `(when (stringp ,label) (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 `(when (stringp ,label) (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 `(when (stringp ,label) (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 `(when (stringp (nth ,(+ nlink nlink) links))
267 (write-string (nth ,(+ nlink nlink) links) s)) print-func)
268 (vector-push-extend '(write-char #\> s) print-func)
269 (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)
270 (vector-push-extend '(write-string "</" s) print-func)
271 (vector-push-extend `(when (stringp (nth ,(+ nlink nlink 1) links))
272 (write-string (nth ,(+ nlink nlink 1) links) s)) print-func)
273 (vector-push-extend '(write-char #\> s) print-func))
275 (defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
276 (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
277 (vector-push-extend `(when (stringp ,label) (write-string ,label s)) print-func)
278 (vector-push-extend '(write-string "</span> " s) print-func)
279 (ppfc-html-link name type formatter cdata nlink print-func))
281 (defun push-print-fun-code (vid slot nlink print-func)
282 (let* ((formatter (esd-print-formatter slot))
283 (name (slot-definition-name slot))
284 (user-name (esd-user-name slot))
285 (xml-user-name (escape-xml-string user-name))
286 (xml-tag (escape-xml-string user-name))
287 (type (slot-definition-type slot))
290 (and (in vid :xml :xhtml :xml-link :xhtml-link
291 :xml-labels :ie-xml-labels
292 :xhtml-link-labels :xml-link-labels :ie-xml-link
295 (lisp-type-is-a-string type))))))
296 (hyperlink (esd-hyperlink slot)))
301 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
302 (:compact-text-labels
303 (vector-push-extend `(write-string ,user-name s) print-func)
304 (vector-push-extend '(write-char #\space s) print-func)
306 `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func))
308 (ppfc-html user-name name type formatter cdata print-func))
310 (ppfc-xml xml-tag name type formatter cdata print-func))
312 (ppfc-html-labels user-name name type formatter cdata print-func))
314 (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func))
315 ((:display-table :display-table-labels)
316 (ppfc-display-table user-name name type formatter cdata print-func))
318 (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func))
319 ((or :html-link :xhtml-link)
321 (ppfc-html-link name type formatter cdata nlink print-func)
322 (ppfc-html user-name name type formatter cdata print-func)))
323 ((or :xml-link :ie-xml-link)
325 (ppfc-html-link name type formatter cdata nlink print-func)
326 (ppfc-xml xml-tag name type formatter cdata print-func)))
329 (ppfc-html-link-labels user-name name type formatter cdata nlink
331 (ppfc-html-labels user-name name type formatter cdata print-func)))
334 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
336 (ppfc-xhtml-labels xml-tag user-name name type formatter cdata
338 ((or :xml-link-labels :ie-xml-link-labels)
340 (ppfc-html-link-labels xml-user-name name type formatter cdata nlink
342 (ppfc-xml-labels xml-tag user-name name type formatter cdata
346 (defun view-has-links-p (view)
347 (in (id view) :html-link :xhtml-link :xml-link :ie-xml-link
348 :html-link-labels :xhtml-link-labels :xml-link-labels
349 :ie-xml-link-labels))
351 (defun creatable-view-id-p (obj-cl vid)
352 "Returns T if a view id can be created for this class"
353 (declare (ignore obj-cl))
354 (in vid :compact-text :compact-text-labels
355 :html :html-labels :html-link-labels
356 :xhtml :xhtml-labels :xhtml-link-labels
357 :xhtml-link :html-link
358 :xml :xml-labels :xml-link :ie-xml-link
359 :xml-link-labels :ie-xml-link-labels
360 :display-table :display-table-labels :edit-table :edit-table-labels))
362 (defun initialize-view-by-id (obj-cl view)
363 "Initialize a view based upon a preset vid"
364 (unless (creatable-view-id-p obj-cl (id view))
365 (error "Unable to automatically create view id ~A" (id view)))
367 (unless (slots view) (setf (slots view) (default-print-slots obj-cl)))
370 (print-func (make-array 20 :fill-pointer 0 :adjustable t)))
372 (do* ((slots (slots view) (cdr slots))
373 (slot-name (car slots) (car slots))
374 (slot (find-slot-by-name obj-cl slot-name)
375 (find-slot-by-name obj-cl slot-name)))
378 (error "Slot ~A is not found in class ~S" slot-name obj-cl))
380 (push-print-fun-code (id view) slot (length links) print-func)
381 (when (> (length slots) 1)
382 (vector-push-extend '(write-char #\space s) print-func))
384 (when (and (view-has-links-p view) (esd-hyperlink slot))
385 (push (slot-definition-name slot) links)))
387 (vector-push-extend 'x print-func) ;; return object
388 (setf (obj-data-print-code view) `(lambda (x s links)
389 (declare (ignorable s links))
390 ,@(map 'list #'identity print-func)))
391 (setf (obj-data-printer view)
392 (compile nil (eval (obj-data-print-code view))))
394 (setf (link-slots view) (nreverse links)))
396 (finalize-view-by-id view)
399 (defun finalize-view-by-id (view)
401 ((or :compact-text :compact-text-labels)
402 (initialize-text-view view))
403 ((or :html :html-labels)
404 (initialize-html-view view))
405 ((or :xhtml :xhtml-labels)
406 (initialize-xhtml-view view))
407 ((or :xml :xml-labels)
408 (initialize-xml-view view))
409 ((or :html-link :html-link-labels)
410 (initialize-html-view view)
411 (setf (link-href-start view) "a href=")
412 (setf (link-href-end view) "a")
413 (setf (link-ampersand view) "&"))
414 ((or :xhtml-link :xhtml-link-labels)
415 (initialize-xhtml-view view)
416 (setf (link-href-start view) "a href=")
417 (setf (link-href-end view) "a")
418 (setf (link-ampersand view) "&"))
419 ((or :display-table :display-table-labels :edit-tables)
420 (initialize-table-view view)
421 (when (in (id view) :display-table-labels :edit-table-labels)
422 (setf (list-start-printer view) #'table-label-list-start-func))
423 (setf (link-href-start view) "a href=")
424 (setf (link-href-end view) "a")
425 (setf (link-ampersand view) "&"))
426 ((or :xml-link :xml-link-labels)
427 (initialize-xml-view view)
428 (setf (link-href-start view)
429 "xmllink xlink:type=\"simple\" xlink:href=")
430 (setf (link-href-end view) "xmllink")
431 (setf (link-ampersand view) "&"))
432 ((or :ie-xml-link :ie-xml-link-labels)
433 (initialize-xml-view view)
434 (setf (link-href-start view) "html:a href=")
435 (setf (link-href-end view) "html:a")
436 (setf (link-ampersand view) "&"))))
439 ;;;; *************************************************************************
440 ;;;; View Data Format Section
441 ;;;; *************************************************************************
443 (defun class-name-of (obj)
444 (string-downcase (class-name (class-of obj))))
446 (defvar +newline-string+ (format nil "~%"))
448 (defun write-user-name-maybe-plural (obj nitems strm)
451 (hyperobject-class-user-name-plural obj)
452 (hyperobject-class-user-name obj))
455 (defun initialize-text-view (view)
456 (setf (list-start-printer view)
458 (eval '(lambda (obj nitems indent strm)
459 (declare (ignore indent))
460 (write-user-name-maybe-plural obj nitems strm)
461 (write-char #\: strm)
462 (write-char #\Newline strm)))))
463 (setf (list-start-indent view) t)
464 (setf (obj-data-indent view) t)
465 (setf (obj-data-end-printer view) +newline-string+)
466 (setf (indenter view) #'indent-spaces))
468 (defun html-list-start-func (obj nitems indent strm)
469 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
470 (write-fixnum (+ indent indent) strm)
471 (write-string "em;\">" strm)
472 (write-user-name-maybe-plural obj nitems strm)
473 (write-string "</div>" strm)
474 (write-char #\newline strm)
475 (write-string "<ul>" strm)
476 (write-char #\newline strm))
478 (defun initialize-html-view (view)
479 (initialize-text-view view)
480 (setf (indenter view) #'indent-spaces)
481 (setf (file-start-str view) (format nil "<html><body>~%"))
482 (setf (file-end-str view) (format nil "</body><html>~%"))
483 (setf (list-start-indent view) t)
484 (setf (list-start-printer view) #'html-list-start-func)
485 (setf (list-end-printer view) (format nil "</ul>~%"))
486 (setf (list-end-indent view) t)
487 (setf (obj-start-indent view) nil)
488 (setf (obj-start-printer view) "<li>")
489 (setf (obj-end-indent view) nil)
490 (setf (obj-end-printer view) (format nil "</li>~%"))
491 (setf (obj-data-end-printer view) nil)
492 (setf (obj-data-indent view) nil))
494 (defun xhtml-list-start-func (obj nitems indent strm)
495 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
496 (write-fixnum (+ indent indent) strm)
497 (write-string "em;\">" strm)
498 (write-user-name-maybe-plural obj nitems strm)
499 (write-string "</div>" strm)
500 (write-string "<div style=\"margin-left:" strm)
501 (write-fixnum (+ indent indent) strm)
502 (write-string "em;\">" strm)
503 (write-char #\newline strm))
505 (defun table-list-start-func (obj nitems indent strm)
506 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
507 (write-fixnum (+ indent indent) strm)
508 (write-string "em;\">" strm)
509 (write-user-name-maybe-plural obj nitems strm)
510 (write-string "</div>" strm)
511 (write-char #\newline strm)
512 (write-string "<table style=\"margin-left:" strm)
513 (write-fixnum (+ indent indent) strm)
514 (write-string "em;\">" strm)
515 (write-string "<tbody>" strm)
516 (write-char #\newline strm))
518 (defun table-label-list-start-func (obj nitems indent strm)
519 (write-string "<div class=\"ho-username\" style=\"margin-left:" strm)
520 (write-fixnum (+ indent indent) strm)
521 (write-string "em;\">" strm)
522 (write-user-name-maybe-plural obj nitems strm)
523 (write-string "</div>" strm)
524 (write-char #\newline strm)
525 (write-string "<table style=\"margin-left:" strm)
526 (write-fixnum (+ indent indent) strm)
527 (write-string "em;\">" strm)
528 (write-string "<thead>" strm)
529 (dolist (slot (default-print-slots (class-of obj)))
530 (write-string "<th>" strm)
531 (write-string (write-to-string slot) strm)
532 (write-string "</th>" strm))
533 (write-string "</thead>" strm)
534 (write-char #\newline strm)
535 (write-string "<tbody>" strm)
536 (write-char #\newline strm))
538 (defun html-obj-start (obj indent strm)
539 (declare (ignore obj indent))
540 (write-string "<div style=\"margin-left:2em;\">" strm))
542 (defun initialize-xhtml-view (view)
543 (initialize-text-view view)
544 (setf (indenter view) #'indent-spaces)
545 (setf (file-start-str view) (format nil "<html><body>~%"))
546 (setf (file-end-str view) (format nil "</body><html>~%"))
547 (setf (list-start-indent view) nil)
548 (setf (list-start-printer view) #'xhtml-list-start-func)
549 (setf (list-end-printer view) (format nil "</div>~%"))
550 (setf (list-end-indent view) nil)
551 (setf (obj-start-indent view) nil)
552 (setf (obj-start-printer view) #'html-obj-start)
553 (setf (obj-end-printer view) (format nil "</div>~%"))
554 (setf (obj-data-indent view) nil))
556 (defun initialize-table-view (view)
557 (initialize-text-view view)
558 (setf (indenter view) #'indent-spaces)
559 (setf (file-start-str view) (format nil "<html><body>~%"))
560 (setf (file-end-str view) (format nil "</body><html>~%"))
561 (setf (list-start-indent view) nil)
562 (setf (list-start-printer view) #'table-list-start-func)
563 (setf (list-end-printer view) (format nil "</tbody>~%</table>~%"))
564 (setf (list-end-indent view) nil)
565 (setf (obj-start-indent view) nil)
566 (setf (obj-start-printer view) #'html-obj-start)
567 (setf (obj-start-printer view) (format nil "<tr>"))
568 (setf (obj-end-printer view) (format nil "</tr>~%"))
569 (setf (obj-data-indent view) nil))
571 (defun xmlformat-list-end-func (x strm)
572 (write-string "</" strm)
573 (write-string (class-name-of x) strm)
574 (write-string "list" strm)
575 (write-string ">" strm)
576 (write-char #\newline strm))
578 (defun xmlformat-list-start-func (x nitems indent strm)
579 (declare (ignore indent))
580 (write-char #\< strm)
581 (write-string (class-name-of x) strm)
582 (write-string "list><title>" strm)
583 (write-user-name-maybe-plural x nitems strm)
584 (write-string ":</title>" strm)
585 (write-char #\newline strm))
587 (defun initialize-xml-view (view)
588 (let ((name (string-downcase (symbol-name (object-class view)))))
589 (setf (file-start-str view) "") ; (std-xml-header)
590 (setf (list-start-indent view) t)
591 (setf (list-start-printer view) #'xmlformat-list-start-func)
592 (setf (list-end-indent view) t)
593 (setf (list-end-printer view) #'xmlformat-list-end-func)
594 (setf (obj-start-printer view) (format nil "<~(~a~)>" name))
595 (setf (obj-start-indent view) t)
596 (setf (obj-end-printer view) (format nil "</~(~a~)>~%" name))
597 (setf (subobj-end-printer view) (format nil "</~(~a~)>~%" name))
598 (setf (subobj-end-indent view) nil)
599 (setf (obj-data-indent view) nil)))
602 ;;; File Start and Ends
604 (defun fmt-file-start (view strm)
605 (awhen (file-start-str view)
606 (write-string it strm)))
608 (defun fmt-file-end (view strm)
609 (awhen (file-end-str view)
610 (write-string it strm)))
612 ;;; List Start and Ends
614 (defun fmt-list-start (obj view strm indent num-items)
615 (when (list-start-indent view)
616 (awhen (indenter view)
617 (funcall it indent strm)))
618 (awhen (list-start-printer view)
620 (write-string it strm)
621 (funcall it obj num-items indent strm))))
623 (defun fmt-list-end (obj view strm indent num-items)
624 (declare (ignore num-items))
625 (when (list-end-indent view)
626 (awhen (indenter view)
627 (funcall it indent strm)))
628 (awhen (list-end-printer view)
630 (write-string it strm)
631 (funcall it obj strm))))
633 ;;; Object Start and Ends
636 (defun fmt-obj-start (obj view strm indent)
637 (when (obj-start-indent view)
638 (awhen (indenter view)
639 (funcall it indent strm)))
640 (awhen (obj-start-printer view)
642 (write-string it strm)
643 (funcall it obj indent strm))))
645 (defun fmt-obj-end (obj view strm indent)
646 (when (obj-end-indent view)
647 (awhen (indenter view)
648 (funcall it indent strm)))
649 (awhen (obj-end-printer view)
651 (write-string it strm)
652 (funcall it obj strm))))
654 (defun fmt-subobj-start (obj view strm indent)
655 (when (subobj-start-indent view)
656 (awhen (indenter view)
657 (funcall it indent strm)))
658 (awhen (subobj-start-printer view)
660 (write-string it strm)
661 (funcall it obj indent strm))))
663 (defun fmt-subobj-end (obj view strm indent)
664 (when (subobj-end-indent view)
665 (awhen (indenter view)
666 (funcall it indent strm)))
667 (awhen (subobj-end-printer view)
669 (write-string it strm)
670 (funcall it obj strm))))
675 (defun make-link-start (view fieldfunc fieldvalue refvars link-printer)
676 (with-output-to-string (s)
677 (write-string (link-href-start view) s)
679 (let ((link-page (link-page view)))
682 (write-string (make-url link-page) s)
683 (write-string "?func=" s)
684 (write-simple fieldfunc s)
685 (write-string (link-ampersand view) s)
686 (write-string "key=" s)
687 (write-simple fieldvalue s)
688 (dolist (var refvars)
689 (write-string (link-ampersand view) s)
690 (write-simple (car var) s)
692 (write-simple (cdr var) s)))
694 (funcall link-printer link-page fieldfunc fieldvalue refvars s))))
697 (defun make-link-end (obj view fieldname)
698 (declare (ignore obj fieldname))
699 (link-href-end view))
701 (defun fmt-obj-data (obj view strm indent refvars link-printer)
702 (awhen (obj-data-start-printer view)
704 (write-string it strm)
705 (funcall it obj strm)))
706 (when (obj-data-indent view)
707 (awhen (indenter view)
708 (funcall it indent strm)))
709 (if (link-slots view)
710 (fmt-obj-data-with-link obj view strm refvars link-printer)
711 (fmt-obj-data-plain obj view strm))
712 (awhen (obj-data-end-printer view)
714 (write-string it strm)
715 (funcall it obj strm))))
717 (defun fmt-obj-data-plain (obj view strm)
718 (awhen (obj-data-printer view)
719 (funcall it obj strm nil)))
721 (defun fmt-obj-data-with-link (obj view strm refvars link-printer)
722 (let ((refvalues '()))
723 (declare (dynamic-extent refvalues))
724 ;; make list of hyperlink link fields for printing to refstr template
725 (dolist (name (link-slots view))
726 (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name)
727 (push (make-link-start view (lookup it) (slot-value obj name)
728 (append (link-parameters it) refvars)
731 (push (make-link-end obj view name) refvalues)))
732 (funcall (obj-data-printer view) obj strm (nreverse refvalues))))
734 (defun obj-data (obj view)
735 "Returns the objects data as a string. Used by common-graphics outline function"
736 (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
738 ;;; Display method for objects
741 (defun load-all-subobjects (objs)
742 "Load all subobjects if they have not already been loaded."
743 (dolist (obj (mklist objs))
744 (dolist (subobj (hyperobject-class-subobjects obj))
745 (awhen (slot-value obj (name-slot subobj))
746 (load-all-subobjects it))))
749 (defun view-subobjects (obj strm &optional vid (indent 0) filter
750 subobjects refvars link-printer)
751 (when (hyperobject-class-subobjects obj)
752 (dolist (subobj (hyperobject-class-subobjects obj))
753 (aif (slot-value obj (name-slot subobj))
755 it (get-view-id (car (mklist it)) vid)
756 strm vid (1+ indent) filter subobjects refvars
760 (defun view-hyperobject (objs view strm &optional vid (indent 0) filter
761 subobjects refvars link-printer)
762 "Display a single or list of hyperobject-class instances and their subobjects"
763 (let-when (objlist (mklist objs))
764 (let ((nobjs (length objlist))
768 (*print-readably* nil)
771 (fmt-list-start (car objlist) view strm indent nobjs)
772 (dolist (obj objlist)
773 (awhen (printer view)
774 (funcall it obj strm))
775 (unless (and filter (not (funcall filter obj)))
776 (fmt-obj-start obj view strm indent)
777 (fmt-obj-data obj view strm (1+ indent) refvars link-printer)
778 (fmt-obj-end obj view strm indent)
781 (fmt-subobj-start obj view strm indent)
782 (view-subobjects obj strm vid indent filter subobjects
783 refvars link-printer)
784 (fmt-subobj-end obj view strm indent))
785 (fmt-subobj-start obj view strm indent))))
786 (fmt-list-end (car objlist) view strm indent nobjs)))
790 (defun view (objs &key (stream *standard-output*) vid view
791 filter subobjects refvars file-wrapper link-printer)
792 "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject"
793 (let-when (objlist (mklist objs))
795 (setq view (get-view-id (car objlist) vid)))
797 (fmt-file-start view stream))
798 (view-hyperobject objlist view stream vid 0 filter subobjects refvars
801 (fmt-file-end view stream)))
807 (defun fmt-comma-integer (i)
808 (format nil "~:d" i))