X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=views.lisp;h=6c102965ef1cbfef5b86a54fe61c4777d48c93bc;hp=c30c0a8cfd1b24c9753bb16f6b31a70fefebab8d;hb=6ff5ef506bb52b4a98cb7a0b3726f5d3a9637944;hpb=9ccad91c1ec86cd90e8b591c29ec85aff9c89268 diff --git a/views.lisp b/views.lisp index c30c0a8..6c10296 100644 --- a/views.lisp +++ b/views.lisp @@ -7,63 +7,91 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.13 2002/12/13 07:33:54 kevin Exp $ -;;;; -;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; $Id: views.lisp,v 1.60 2003/07/11 18:02:41 kevin Exp $ ;;;; +;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* -(in-package :hyperobject) - -(eval-when (:compile-toplevel :execute) - (declaim (optimize (speed 2) (safety 2) (compilation-speed 0) (debug 2)))) +(in-package #:hyperobject) (defclass object-view () ((object-class :initform nil :initarg :object-class - :documentation "Name of class for object to be viewed.") - (slots :initform nil :initarg :slots + :accessor object-class + :documentation "Class of object to be viewed.") + (slots :initform nil :initarg :slots :accessor slots :documentation "List of effective slots for object to be viewed.") - (name :initform nil :initarg :name + (name :initform nil :initarg :name :accessor name :documentation "Name for this view.") - (category :initform nil :initarg :category :reader category + (category :initform nil :initarg :category :accessor category :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.") - (source-code :initform nil :initarg :source-code + (source-code :initform nil :initarg :source-code :accessor source-code :documentation "Source code for generating view.") (country-language :initform :en :initarg :country-language :documentation "Country's Language for this view.") + (printer :initform nil :initarg :printer :accessor printer + :documentation "default function that prints the object") ;; - (file-start-str :type string :initform nil :initarg :file-start-str) - (file-end-str :type string :initform nil :initarg :file-end-str) - (list-start-fmtstr :type string :initform nil :initarg :list-start-fmtstr) - (list-start-value-func :type function :initform nil - :initarg :list-start-value-func) - (list-start-indent :initform nil :initarg :list-start-indent) - (list-end-fmtstr :type string :initform nil :initarg :list-end-fmtstr) - (list-end-value-func :type function :initform nil - :initarg :list-end-value-func) - (list-end-indent :initform nil :initarg :list-end-indent) - (obj-start-fmtstr :type string :initform nil :initarg :obj-start-fmtstr) - (obj-start-value-func :initform nil :initarg :obj-start-value-func) - (obj-start-indent :initform nil :initarg :obj-start-indent) - (obj-end-fmtstr :type string :initform nil :initarg :obj-end-fmtstr) - (obj-end-value-func :type function :initform nil - :initarg :obj-end-value-func) - (obj-end-indent :initform nil :initarg :obj-end-indent) - (obj-data-indent :initform nil :initarg :obj-data-indent) - (obj-data-fmtstr :type string :initform nil :initarg :obj-data-fmtstr) - (obj-data-end-fmtstr :type string :initform nil - :initarg :obj-data-end-fmtstr) - (obj-data-value-func :type function :initform nil - :initarg :obj-data-value-func) - + (file-start-str :type (or string null) :initform nil :initarg :file-start-str + :accessor file-start-str) + (file-end-str :type (or string null) :initform nil :initarg :file-end-str + :accessor file-end-str) + (list-start-printer :type (or string function null) :initform nil + :initarg :list-start-printer + :accessor list-start-printer) + (list-start-indent :initform nil :initarg :list-start-indent + :accessor list-start-indent) + (list-end-printer :type (or string function null) :initform nil + :initarg :list-end-printer + :accessor list-end-printer) + (list-end-indent :initform nil :initarg :list-end-indent + :accessor list-end-indent) + (obj-start-printer :type (or string function null) :initform nil :initarg :obj-start-printer + :accessor obj-start-printer) + (obj-start-indent :initform nil :initarg :obj-start-indent + :accessor obj-start-indent) + (obj-end-printer :type (or string function null) :initform nil :initarg :obj-end-printer + :accessor obj-end-printer) + (obj-end-indent :initform nil :initarg :obj-end-indent + :accessor obj-end-indent) + (subobj-start-printer :type (or string function null) :initform nil :initarg :subobj-start-printer + :accessor subobj-start-printer) + (subobj-start-indent :initform nil :initarg :subobj-start-indent + :accessor subobj-start-indent) + (subobj-end-printer :type (or string function null) :initform nil :initarg :subobj-end-printer + :accessor subobj-end-printer) + (subobj-end-indent :initform nil :initarg :subobj-end-indent + :accessor subobj-end-indent) + (obj-data-indent :initform nil :initarg :obj-data-indent + :accessor obj-data-indent) + (obj-data-printer :type (or function null) :initform nil + :initarg :obj-data-printer + :accessor obj-data-printer) + (obj-data-print-code :type (or function null) :initform nil + :initarg :obj-data-print-code + :accessor obj-data-print-code) + (obj-data-start-printer :type (or function string null) :initform nil + :initarg :obj-data-start-printer + :accessor obj-data-start-printer) + (obj-data-end-printer :type (or string null) :initform nil + :initarg :obj-data-end-printer + :accessor obj-data-end-printer) + (indenter :type (or function null) :initform nil + :accessor indenter + :documentation "Function that performs hierarchical indenting") (link-slots :type list :initform nil - :documentation "List of slot names that have hyperlinks") - (link-page-name :type string :initform nil :initarg :link-page-name) - (link-href-start :type string :initform nil :initarg :link-href-start) - (link-href-end :type string :initform nil :initarg :link-href-end) - (link-ampersand :type string :initform nil :initarg :link-ampersand)) - (:default-initargs :link-page-name "disp-func1") + :documentation "List of slot names that have hyperlinks" + :accessor link-slots) + (link-page :type (or string null) :initform nil + :initarg :link-page + :accessor link-page) + (link-href-start :type (or string null) :initform nil :initarg :link-href-start + :accessor link-href-start) + (link-href-end :type (or string null) :initform nil :initarg :link-href-end + :accessor link-href-end) + (link-ampersand :type (or string null) :initform nil :initarg :link-ampersand + :accessor link-ampersand)) + (:default-initargs :link-page "lookup-func1") (:documentation "View class for a hyperobject")) @@ -71,13 +99,14 @@ "Find or make a category view for an object" (let ((obj-class (class-of obj))) (if (null category) - (slot-value obj-class 'default-view) + (default-view obj-class) (aif (find category (views obj-class) :key #'category) it (let ((view - (make-instance 'object-view :object-class (class-name obj-class) - :category category - :slots slots))) + (make-instance 'object-view + :object-class (find-class obj-class) + :category category + :slots slots))) (push view (views obj-class)) view))))) @@ -87,20 +116,18 @@ (defun finalize-views (cl) "Finalize all views that are given on a objects initialization" - (unless (slot-value cl 'default-print-slots) - (setf (slot-value cl 'default-print-slots) + (unless (default-print-slots cl) + (setf (default-print-slots cl) (mapcar #'slot-definition-name (class-slots cl)))) (let ((views '())) - (dolist (view-def (slot-value cl 'views)) + (dolist (view-def (direct-views cl)) (push (make-object-view cl view-def) views)) - (setf (slot-value cl 'views) (nreverse views))) + (setf (views cl) (nreverse views))) (cond - ((default-view cl) - (setf (slot-value cl 'default-view) (make-object-view cl (default-view cl)))) - ((car (views cl)) - (setf (slot-value cl 'default-view) (make-object-view cl (car (views cl))))) + ((views cl) + (setf (default-view cl) (car (views cl)))) (t - (setf (slot-value cl 'default-view) (make-object-view cl :default))))) + (setf (default-view cl) (make-object-view cl :default))))) (defun make-object-view (cl view-def) "Make an object view from a definition. Do nothing if a class is passed so that reinitialization will be a no-op" @@ -110,141 +137,264 @@ ((eq view-def :default) (let* ((name (class-name cl)) (view (make-instance 'object-view :name "automatic" - :object-class name + :object-class (class-name cl) :category :compact-text))) view)) ((consp view-def) - (eval `(make-instance ,view-def))) + (make-instance 'object-view + :object-class (class-name cl) + :name (getf view-def :name) + :source-code (getf view-def :source-code))) (t (error "Invalid parameter to make-object-view: ~S" view-def)))) -(defmethod initialize-instance :after ((view object-view) - &rest initargs &key &allow-other-keys) - (initialize-view (find-class (slot-value view 'object-class)) view)) +(defmethod initialize-instance :after ((self object-view) + &rest initargs + &key + &allow-other-keys) + (initialize-view self)) -(defun initialize-view (obj-cl view) +(defun initialize-view (view) "Calculate all view slots for a hyperobject class" - (let ((fmtstr nil) - (first-field t) - (value-func '()) - (links '()) - (category (category view))) - (unless (slot-value view 'slots) - (setf (slot-value view 'slots) (slot-value obj-cl 'default-print-slots))) - (dolist (slot-name (slot-value view 'slots)) - (let ((slot (find-slot-by-name obj-cl slot-name))) - (unless slot - (error "Slot ~A is not found in class ~S" slot-name obj-cl)) - (let ((name (slot-definition-name slot)) - (namestr-lower (string-downcase (symbol-name (slot-definition-name slot)))) - (type (slot-value slot 'type)) - (print-formatter (slot-value slot 'print-formatter))) - - (cond - (first-field - (setq fmtstr "") - (setq first-field nil)) - (t - (string-append fmtstr " "))) - - (when (slot-value slot 'hyperlink) - (push name links)) - - (let ((value-fmt - (case type - ((or :integer :fixnum) - "~d") - (:boolean - "~a") - (otherwise - "~a")))) - (case category - (:compact-text - (string-append fmtstr value-fmt)) - (:compact-text-labels - (string-append fmtstr namestr-lower " " value-fmt)) - ((or :html :xhtml) - (string-append fmtstr (concatenate 'string "" value-fmt ""))) - (:xml - (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt ""))) - (:html-label - (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt ""))) - (:xhtml-label - (string-append fmtstr (concatenate 'string " " value-fmt ""))) - (:xml-labels - (string-append fmtstr (concatenate 'string " <" namestr-lower ">" value-fmt ""))) - ((or :html-link :xhtml-link) - (if (slot-value slot 'hyperlink) - (string-append fmtstr "<~~a>" value-fmt "") - (string-append fmtstr (concatenate 'string "" value-fmt "")))) - (:xml-link - (if (slot-value slot 'hyperlink) - (string-append fmtstr "<~~a>" value-fmt "") - (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "")))) - (:html-link-labels - (if (slot-value slot 'hyperlink) - (string-append fmtstr "" namestr-lower " <~~a>" value-fmt "") - (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt "")))) - (:xhtml-link-labels - (if (slot-value slot 'hyperlink) - (string-append fmtstr "<[!CDATA[" namestr-lower "]]> <~~a>" value-fmt "") - (string-append fmtstr (concatenate 'string " " value-fmt "")))) - (:xml-link-labels - (if (slot-value slot 'hyperlink) - (string-append fmtstr " <~~a>" value-fmt "") - (string-append fmtstr (concatenate 'string " <" namestr-lower ">" value-fmt ""))))) - ) ;; let value-fmt - - (let ((func (if print-formatter - `(,print-formatter (slot-value x (quote ,name))) - `(slot-value x (quote ,name))))) - (when (and (in category :xml :xhtml :xml-link :xhtml-link - :xhtml-link-labels :xml-link-labels :ie-xml-link - :ie-xml-link-labels) - (or print-formatter - (string-equal (write-to-string type) "string"))) - (setq func `(kmrcl:xml-cdata ,func))) - (push func value-func)) - ))) - - (when value-func - (setq value-func - (compile nil (eval `(lambda (x) (values ,@(nreverse value-func))))))) - - (setf (slot-value view 'obj-data-fmtstr) fmtstr) - (setf (slot-value view 'obj-data-value-func) value-func) - (setf (slot-value view 'link-slots) (nreverse links)) + (let ((obj-cl (find-class (object-class view)))) + (cond + ((category view) + (initialize-view-by-category obj-cl view)) + ((source-code view) + (initialize-view-by-source-code view)) + (t + (setf (category view) :compact-text) + (initialize-view-by-category obj-cl view))))) + +(defun initialize-view-by-source-code (view) + "Initialize a view based upon a source code" + (let* ((source-code (source-code view)) + (*package* (symbol-package (object-class view))) + (printer `(lambda (x s) + (declare (ignorable x s)) + ,@source-code))) + (setf (printer view) + (compile nil (eval printer))))) + +(defmacro write-simple (v s) + `(typecase ,v + (string + (write-string ,v ,s)) + (fixnum + (write-fixnum ,v ,s)) + (symbol + (write-string (symbol-name ,v) ,s)) + (t + (write-string (write-to-string ,v) ,s)))) + +(defun write-ho-value (obj name type formatter cdata strm) + (declare (ignorable type)) + (let* ((slot-data (slot-value obj name)) + (fmt-data (if formatter + (funcall formatter slot-data) + slot-data))) + (if cdata + (write-xml-cdata fmt-data strm) + (write-simple fmt-data strm)))) + +(defun ppfc-html (title name type formatter cdata print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) + (vector-push-extend '(write-string "" s) print-func)) + +(defun ppfc-xml (tag name type formatter cdata print-func) + (vector-push-extend '(write-char #\< s) print-func) + (vector-push-extend `(write-string ,tag s) print-func) + (vector-push-extend '(write-char #\> s) print-func) + (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) + (vector-push-extend '(write-string " s) print-func)) + +(defun ppfc-html-labels (label name type formatter cdata print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-html label name type formatter cdata print-func)) + +(defun ppfc-xhtml-labels (label tag name type formatter cdata print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-html tag name type formatter cdata print-func)) + +(defun ppfc-xml-labels (label tag name type formatter cdata print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-xml tag name type formatter cdata print-func)) + +(defun ppfc-html-link (name type formatter cdata nlink print-func) + (declare (fixnum nlink)) + (vector-push-extend '(write-char #\< s) print-func) + (vector-push-extend `(write-string (nth ,(+ nlink nlink) links) s) print-func) + (vector-push-extend '(write-char #\> s) print-func) + (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func) + (vector-push-extend '(write-string " s) print-func)) + +(defun ppfc-html-link-labels (label name type formatter cdata nlink print-func) + (vector-push-extend '(write-string "" s) print-func) + (vector-push-extend `(write-string ,label s) print-func) + (vector-push-extend '(write-string " " s) print-func) + (ppfc-html-link name type formatter cdata nlink print-func)) + +(defun push-print-fun-code (category slot nlink print-func) + (let* ((formatter (esd-print-formatter slot)) + (name (slot-definition-name slot)) + (user-name (esd-user-name slot)) + (xml-user-name (escape-xml-string user-name)) + (xml-tag (escape-xml-string user-name)) + (type (slot-value slot 'type)) + (cdata (not (null + (and (in category :xml :xhtml :xml-link :xhtml-link + :xml-labels :ie-xml-labels + :xhtml-link-labels :xml-link-labels :ie-xml-link + :ie-xml-link-labels) + (or formatter + (lisp-type-is-a-string type)))))) + (hyperlink (esd-hyperlink slot))) (case category - ((or :compact-text :compact-text-labels) - (initialize-text-view view)) - ((or :html :xhtml :html-labels :xhtml-labels) - (initialize-html-view view)) - ((or :xml :xml-labels) - (initialize-xml-view view)) - ((or :html-link :html-link-labels) - (initialize-html-view view) - (setf (slot-value view 'link-href-start) "a href=") - (setf (slot-value view 'link-href-end) "a") - (setf (slot-value view 'link-ampersand) "&")) - ((or :xhtml-link :xhtml-link-labels) - (initialize-html-view view) - (setf (slot-value view 'link-href-start) "a href=") - (setf (slot-value view 'link-href-end) "a") - (setf (slot-value view 'link-ampersand) "&")) - ((or :xml-link :xml-link-labels) - (initialize-xml-view view) - (setf (slot-value view 'link-href-start) - "xmllink xlink:type=\"simple\" xlink:href=") - (setf (slot-value view 'link-href-end) "xmllink") - (setf (slot-value view 'link-ampersand) "&")) - ((or :ie-xml-link :ie-xml-link-labels) - (initialize-xml-view view) - (setf (slot-value view 'link-href-start) "html:a href=") - (setf (slot-value view 'link-href-end) "html:a") - (setf (slot-value view 'link-ampersand) "&")))) + (:compact-text + (vector-push-extend + `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) + (:compact-text-labels + (vector-push-extend `(write-string ,user-name s) print-func) + (vector-push-extend '(write-char #\space s) print-func) + (vector-push-extend + `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) + ((or :html :xhtml) + (ppfc-html user-name name type formatter cdata print-func)) + (:xml + (ppfc-xml xml-tag name type formatter cdata print-func)) + (:html-labels + (ppfc-html-labels user-name name type formatter cdata print-func)) + (:xhtml-labels + (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func)) + (:xml-labels + (ppfc-xml-labels xml-user-name xml-tag name type formatter cdata print-func)) + ((or :html-link :xhtml-link) + (if hyperlink + (ppfc-html-link name type formatter cdata nlink print-func) + (ppfc-html user-name name type formatter cdata print-func))) + ((or :xml-link :ie-xml-link) + (if hyperlink + (ppfc-html-link name type formatter cdata nlink print-func) + (ppfc-xml xml-tag name type formatter cdata print-func))) + (:html-link-labels + (if hyperlink + (ppfc-html-link-labels user-name name type formatter cdata nlink + print-func) + (ppfc-html-labels user-name name type formatter cdata print-func))) + (:xhtml-link-labels + (if hyperlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink + print-func) + (ppfc-xhtml-labels xml-tag user-name name type formatter cdata + print-func))) + ((or :xml-link-labels :ie-xml-link-labels) + (if hyperlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink + print-func) + (ppfc-xml-labels xml-tag user-name name type formatter cdata + print-func)))))) + + +(defun view-has-links-p (view) + (in (category view) :html-link :xhtml-link :xml-link :ie-xml-link + :html-link-labels :xhtml-link-labels :xml-link-labels + :ie-xml-link-labels)) + +(defun initialize-view-by-category (obj-cl view) + "Initialize a view based upon a preset category" + (unless (in (category view) :compact-text :compact-text-labels + :html :html-labels :html-link-labels + :xhtml :xhtml-labels :xhtml-link-labels + :xhtml-link :html-link + :xml :xml-labels :xml-link :ie-xml-link + :xml-link-labels :ie-xml-link-labels + :display-table :edit-table) + (error "Unknown view category ~A" (category view))) + + (unless (slots view) (setf (slots view) (default-print-slots obj-cl))) + + (let ((links '()) + (print-func (make-array 10 :fill-pointer 0 :adjustable t))) + + (do* ((slots (slots view) (cdr slots)) + (slot-name (car slots) (car slots)) + (slot (find-slot-by-name obj-cl slot-name) + (find-slot-by-name obj-cl slot-name))) + ((null slots)) + (unless slot + (error "Slot ~A is not found in class ~S" slot-name obj-cl)) + + (push-print-fun-code (category view) slot (length links) print-func) + (when (> (length slots) 1) + (vector-push-extend '(write-char #\space s) print-func)) + + (when (and (view-has-links-p view) (esd-hyperlink slot)) + (push (slot-definition-name slot) links))) + + (vector-push-extend 'x print-func) ;; return object + (setf (obj-data-print-code view) `(lambda (x s links) + (declare (ignorable s links)) + ,@(map 'list #'identity print-func))) + (setf (obj-data-printer view) + (compile nil (eval (obj-data-print-code view)))) + + (setf (link-slots view) (nreverse links))) + + (finalize-view-by-category view) view) +(defun finalize-view-by-category (view) + (case (category view) + ((or :compact-text :compact-text-labels) + (initialize-text-view view)) + ((or :html :html-labels) + (initialize-html-view view)) + ((or :xhtml :xhtml-labels) + (initialize-xhtml-view view)) + ((or :xml :xml-labels) + (initialize-xml-view view)) + ((or :html-link :html-link-labels) + (initialize-html-view view) + (setf (link-href-start view) "a href=") + (setf (link-href-end view) "a") + (setf (link-ampersand view) "&")) + ((or :xhtml-link :xhtml-link-labels) + (initialize-xhtml-view view) + (setf (link-href-start view) "a href=") + (setf (link-href-end view) "a") + (setf (link-ampersand view) "&")) + ((or :xml-link :xml-link-labels) + (initialize-xml-view view) + (setf (link-href-start view) + "xmllink xlink:type=\"simple\" xlink:href=") + (setf (link-href-end view) "xmllink") + (setf (link-ampersand view) "&")) + ((or :ie-xml-link :ie-xml-link-labels) + (initialize-xml-view view) + (setf (link-href-start view) "html:a href=") + (setf (link-href-end view) "html:a") + (setf (link-ampersand view) "&")))) + + +(defun make-std-object-slots-view (class-name slots) + #'(lambda (obj strm) + ) + + ) ;;;; ************************************************************************* ;;;; View Data Format Section @@ -253,196 +403,247 @@ (defun class-name-of (obj) (string-downcase (class-name (class-of obj)))) -(defun text-list-start-value-func (obj nitems) - (values (hyperobject-class-user-name obj) nitems)) +(defvar +newline-string+ (format nil "~%")) -(defun htmlformat-list-start-value-func (x nitems) - (values (hyperobject-class-user-name x) nitems (class-name-of x))) +(defun write-user-name-maybe-plural (obj nitems strm) + (write-string + (if (> nitems 1) + (hyperobject-class-user-name-plural obj) + (hyperobject-class-user-name obj)) + strm)) (defun initialize-text-view (view) - (setf (slot-value view 'list-start-fmtstr) "~a~P:~%") - (setf (slot-value view 'list-start-value-func) #'text-list-start-value-func) - (setf (slot-value view 'list-start-indent) t) - (setf (slot-value view 'obj-data-indent) t) - (setf (slot-value view 'obj-data-end-fmtstr) (format nil "~%")) - ) + (setf (list-start-printer view) + (compile nil + (eval '(lambda (obj nitems indent strm) + (declare (ignore indent)) + (write-user-name-maybe-plural obj nitems strm) + (write-char #\: strm) + (write-char #\Newline strm))))) + (setf (list-start-indent view) t) + (setf (obj-data-indent view) t) + (setf (obj-data-end-printer view) +newline-string+) + (setf (indenter view) #'indent-spaces)) + +(defun html-list-start-func (obj nitems indent strm) + (write-string "
" strm) + (write-user-name-maybe-plural obj nitems strm) + (write-string "
" strm) + (write-char #\newline strm) + (write-string "~%")) + (setf (list-end-indent view) t) + (setf (obj-start-indent view) nil) + (setf (obj-start-printer view) "
  • ") + (setf (obj-end-indent view) nil) + (setf (obj-end-printer view) (format nil "
    • ~%")) + (setf (obj-data-end-printer view) nil) + (setf (obj-data-indent view) nil)) + +(defun xhtml-list-start-func (obj nitems indent strm) + (write-string "
    " strm) + (write-user-name-maybe-plural obj nitems strm) + (write-string "
    " strm) + (write-string "
    " strm) + (write-char #\newline strm)) + +(defun html-obj-start (obj indent strm) + (declare (ignore obj indent)) + (write-string "
    " strm)) (defun initialize-xhtml-view (view) (initialize-text-view view) - (setf (slot-value view 'file-start-str) (format nil "~%")) - (setf (slot-value view 'file-end-str) (format nil "~%")) - (setf (slot-value view 'list-start-indent) t) - (setf (slot-value view 'list-start-fmtstr) - "

    ~a~p:

      ~%") - (setf (slot-value view 'list-start-value-func) - #'htmlformat-list-start-value-func) - (setf (slot-value view 'list-end-fmtstr) (format nil "
    ~%")) - (setf (slot-value view 'list-end-indent) t) - (setf (slot-value view 'list-end-value-func) nil) - (setf (slot-value view 'obj-start-indent) t) - (setf (slot-value view 'obj-start-fmtstr) "
  • ") - (setf (slot-value view 'obj-start-value-func) nil) - (setf (slot-value view 'obj-end-indent) t) - (setf (slot-value view 'obj-end-fmtstr) (format nil "
    • ~%")) - (setf (slot-value view 'obj-end-value-func) nil) - (setf (slot-value view 'obj-data-indent) t)) - -(defun xmlformat-list-end-value-func (x) - (format nil "~alist" (class-name-of x))) - -(defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name x) nitems)) + (setf (indenter view) #'indent-spaces) + (setf (file-start-str view) (format nil "~%")) + (setf (file-end-str view) (format nil "~%")) + (setf (list-start-indent view) nil) + (setf (list-start-printer view) #'xhtml-list-start-func) + (setf (list-end-printer view) (format nil "
    ~%")) + (setf (list-end-indent view) nil) + (setf (obj-start-indent view) nil) + (setf (obj-start-printer view) #'html-obj-start) + (setf (obj-end-printer view) (format nil "
    ~%")) + (setf (obj-data-indent view) nil)) + +(defun xmlformat-list-end-func (x strm) + (write-string "" strm) + (write-char #\newline strm)) + +(defun xmlformat-list-start-func (x nitems indent strm) + (declare (ignore indent)) + (write-char #\< strm) + (write-string (class-name-of x) strm) + (write-string "list>" strm) + (write-user-name-maybe-plural x nitems strm) + (write-string ":" strm) + (write-char #\newline strm)) (defun initialize-xml-view (view) - (initialize-text-view view) - (setf (slot-value view 'file-start-str) "") ; (std-xml-header) - (setf (slot-value view 'list-start-indent) t) - (setf (slot-value view 'list-start-fmtstr) "<~a>~a~p: ~%") - (setf (slot-value view 'list-start-value-func) - #'xmlformat-list-start-value-func) - (setf (slot-value view 'list-end-indent) t) - (setf (slot-value view 'list-end-fmtstr) "~%") - (setf (slot-value view 'list-end-value-func) #'xmlformat-list-end-value-func) - (setf (slot-value view 'obj-start-fmtstr) (format nil "<~(~a~)>" (slot-value view 'object-class))) - (setf (slot-value view 'obj-start-indent) t) - (setf (slot-value view 'obj-end-fmtstr) (format nil "~%" (slot-value view 'object-class))) - (setf (slot-value view 'obj-end-indent) nil) - (setf (slot-value view 'obj-data-indent) nil)) + (setf (file-start-str view) "") ; (std-xml-header) + (setf (list-start-indent view) t) + (setf (list-start-printer view) #'xmlformat-list-start-func) + (setf (list-end-indent view) t) + (setf (list-end-printer view) #'xmlformat-list-end-func) + (setf (obj-start-printer view) (format nil "<~(~a~)>" (object-class-name view))) + (setf (obj-start-indent view) t) + (setf (subobj-end-printer view) (format nil "~%" (object-class-name view))) + (setf (subobj-end-indent view) nil) + (setf (obj-data-indent view) nil)) ;;; File Start and Ends (defun fmt-file-start (view strm) - (awhen (slot-value view 'file-start-str) + (awhen (file-start-str view) (write-string it strm))) (defun fmt-file-end (view strm) - (awhen (slot-value view 'file-end-str) + (awhen (file-end-str view) (write-string it strm))) ;;; List Start and Ends (defun fmt-list-start (obj view strm indent num-items) - (when (slot-value view 'list-start-indent) - (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'list-start-fmtstr)) - (let-if (value-func (slot-value view 'list-start-value-func)) - (apply #'format strm fmtstr - (multiple-value-list (funcall value-func - obj num-items))) - (write-string fmtstr strm)))) + (when (list-start-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (list-start-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj num-items indent strm)))) (defun fmt-list-end (obj view strm indent num-items) (declare (ignore num-items)) - (when (slot-value view 'list-end-indent) - (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'list-end-fmtstr)) - (let-if (value-func (slot-value view 'list-end-value-func)) - (apply #'format strm fmtstr (multiple-value-list - (funcall value-func obj))) - (write-string fmtstr strm)))) + (when (list-end-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (list-end-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) ;;; Object Start and Ends + (defun fmt-obj-start (obj view strm indent) - (when (slot-value view 'obj-start-indent) - (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'obj-start-fmtstr)) - (let-if (value-func (slot-value view 'obj-start-value-func)) - (apply #'format strm fmtstr (multiple-value-list - (funcall value-func obj))) - (write-string fmtstr strm)))) + (when (obj-start-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (obj-start-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj indent strm)))) (defun fmt-obj-end (obj view strm indent) - (when (slot-value view 'obj-end-indent) - (indent-spaces indent strm)) - (let-when (fmtstr (slot-value view 'obj-end-fmtstr)) - (let-if (value-func (slot-value view 'obj-end-value-func)) - (apply #'format strm fmtstr (multiple-value-list - (funcall value-func obj))) - (write-string fmtstr strm)))) + (when (obj-end-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (obj-end-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) + +(defun fmt-subobj-start (obj view strm indent) + (when (subobj-start-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (subobj-start-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj indent strm)))) + +(defun fmt-subobj-end (obj view strm indent) + (when (subobj-end-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (awhen (subobj-end-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) ;;; Object Data -(defun make-link-start (view fieldfunc fieldvalue refvars) - (format nil "~a\"~a?func=~a~akey=~a~a\"" - (slot-value view 'link-href-start) - (make-url (slot-value view 'link-page-name)) - fieldfunc - (slot-value view 'link-ampersand) fieldvalue - (if refvars - (let ((varstr "")) - (dolist (var refvars) - (string-append - varstr (slot-value view 'ampersand) - (format nil "~a=~a" (car var) (cadr var)))) - varstr) - ""))) +(defun make-link-start (view fieldfunc fieldvalue refvars link-printer) + (with-output-to-string (s) + (write-string (link-href-start view) s) + (write-char #\" s) + (let ((link-page (link-page view))) + (cond + ((null link-printer) + (write-string (make-url link-page) s) + (write-string "?func=" s) + (write-simple fieldfunc s) + (write-string (link-ampersand view) s) + (write-string "key=" s) + (write-simple fieldvalue s) + (dolist (var refvars) + (write-string (link-ampersand view) s) + (write-simple (car var) s) + (write-char #\= s) + (write-simple (cdr var) s))) + (link-printer + (funcall link-printer link-page fieldfunc fieldvalue refvars s)))) + (write-char #\" s))) + (defun make-link-end (obj view fieldname) (declare (ignore obj fieldname)) - ;;(format nil "~a" (href-end ref)) - (slot-value view 'link-href-end) - ) - -(defun fmt-obj-data (obj view strm indent refvars) - (when (slot-value view 'obj-data-indent) - (indent-spaces indent strm)) - (if (slot-value view 'link-slots) - (fmt-obj-data-with-link obj view strm refvars) + (link-href-end view)) + +(defun fmt-obj-data (obj view strm indent refvars link-printer) + (awhen (obj-data-start-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm))) + (when (obj-data-indent view) + (awhen (indenter view) + (funcall it indent strm))) + (if (link-slots view) + (fmt-obj-data-with-link obj view strm refvars link-printer) (fmt-obj-data-plain obj view strm)) - (awhen (slot-value view 'obj-data-end-fmtstr) - (format strm it))) + (awhen (obj-data-end-printer view) + (if (stringp it) + (write-string it strm) + (funcall it obj strm)))) (defun fmt-obj-data-plain (obj view strm) - (awhen (slot-value view 'obj-data-value-func) - (apply #'format strm (slot-value view 'obj-data-fmtstr) - (multiple-value-list (funcall it obj))))) + (awhen (obj-data-printer view) + (funcall it obj strm nil))) -(defun fmt-obj-data-with-link (obj view strm refvars) +(defun fmt-obj-data-with-link (obj view strm refvars link-printer) (let ((refvalues '())) + (declare (dynamic-extent refvalues)) ;; make list of hyperlink link fields for printing to refstr template - (dolist (name (slot-value view 'link-slots)) - (let ((hyperlink - (find name (hyperobject-class-hyperlinks obj) :key #'name))) - (push (make-link-start view (lookup hyperlink) (slot-value obj name) - (append (link-parameters hyperlink) refvars)) - refvalues) - (push (make-link-end obj view name) refvalues))) - (setq refvalues (nreverse refvalues)) - (apply #'format strm (make-link-data-str obj view) refvalues))) + (dolist (name (link-slots view)) + (awhen (find name (hyperobject-class-hyperlinks obj) :key #'name) + (push (make-link-start view (lookup it) (slot-value obj name) + (append (link-parameters it) refvars) + link-printer) + refvalues) + (push (make-link-end obj view name) refvalues))) + (funcall (obj-data-printer view) obj strm (nreverse refvalues)))) (defun obj-data (obj view) "Returns the objects data as a string. Used by common-graphics outline function" - (awhen (slot-value view 'obj-data-value-func) - (apply #'format nil (funcall (slot-value view 'obj-data-fmtstr)) - (multiple-value-list (funcall it obj))))) - -(defun make-link-data-str (obj view) - "Return fmt string for that contains ~a slots for hyperlink link start and end" - (awhen (slot-value view 'obj-data-value-func) - (apply #'format nil (slot-value view 'obj-data-fmtstr) - (multiple-value-list (funcall it obj))))) + (with-output-to-string (s) (fmt-obj-data-plain obj view s))) ;;; Display method for objects @@ -455,8 +656,19 @@ (load-all-subobjects it)))) objs) -(defun view-hyperobject (objs view category strm &optional (indent 0) filter - subobjects refvars) +(defun view-subobjects (obj strm &optional category (indent 0) filter + subobjects refvars link-printer) + (when (hyperobject-class-subobjects obj) + (dolist (subobj (hyperobject-class-subobjects obj)) + (aif (slot-value obj (name-slot subobj)) + (view-hyperobject + it (get-category-view (car (mklist it)) category) + category strm (1+ indent) filter subobjects refvars + link-printer))))) + + +(defun view-hyperobject (objs view strm &optional category (indent 0) filter + subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" (let-when (objlist (mklist objs)) (let ((nobjs (length objlist)) @@ -468,23 +680,24 @@ (*print-level* nil)) (fmt-list-start (car objlist) view strm indent nobjs) (dolist (obj objlist) - (unless (and filter (not (funcall filter obj))) - (fmt-obj-start obj view strm indent) - (fmt-obj-data obj view strm (1+ indent) refvars) - (when (and subobjects (hyperobject-class-subobjects obj)) - (dolist (subobj (hyperobject-class-subobjects obj)) - (aif (slot-value obj (name-slot subobj)) - (view-hyperobject it (get-category-view (car (mklist it)) category) - category strm (1+ indent) filter - subobjects refvars)))) - (fmt-obj-end obj view strm indent))) + (awhen (printer view) + (funcall it obj strm)) + (unless (and filter (not (funcall filter obj))) + (fmt-obj-start obj view strm indent) + (fmt-obj-data obj view strm (1+ indent) refvars link-printer) + (fmt-obj-end obj view strm indent) + (when subobjects + (fmt-subobj-start obj view strm indent) + (view-subobjects obj category strm indent filter subobjects + refvars link-printer) + (fmt-subobj-end obj view strm indent)))) (fmt-list-end (car objlist) view strm indent nobjs))) objs) (defun view (objs &key (stream *standard-output*) category view - filter subobjects refvars file-wrapper) - "EXPORTED Function: prints hyperobject-class objects. Simplies call to view-hyperobject" + filter subobjects refvars file-wrapper link-printer) + "EXPORTED Function: prints hyperobject-class objects. Calls view-hyperobject" (let-when (objlist (mklist objs)) (when category (setq view (get-category-view (car objlist) category))) @@ -492,7 +705,8 @@ (setq view (default-view (class-of (car objlist))))) (when file-wrapper (fmt-file-start view stream)) - (view-hyperobject objlist view category stream 0 filter subobjects refvars) + (view-hyperobject objlist view stream category 0 filter subobjects refvars + link-printer) (when file-wrapper (fmt-file-end view stream))) objs) @@ -502,4 +716,3 @@ (defun fmt-comma-integer (i) (format nil "~:d" i)) -