X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=836a43cac97bd011fee9942fb96557f28ee927e5;hb=5de0b4ebdcffc6438060a08ceeb582f013aca25b;hp=6c7b9faef997129baff6515a300461f4dd9601fa;hpb=e34bf03b10157e5594b3000be9aa6e3cedc44542;p=hyperobject.git diff --git a/views.lisp b/views.lisp index 6c7b9fa..836a43c 100644 --- a/views.lisp +++ b/views.lisp @@ -7,15 +7,12 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.45 2003/05/16 07:35:09 kevin Exp $ +;;;; $Id: views.lisp,v 1.55 2003/06/17 04:56:02 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 () @@ -40,29 +37,29 @@ :accessor file-start-str) (file-end-str :type (or string null) :initform nil :initarg :file-end-str :accessor file-end-str) - (list-start-str-or-func :type (or string function null) :initform nil - :initarg :list-start-str-or-func - :accessor list-start-str-or-func) + (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-str-or-func :type (or string function null) :initform nil - :initarg :list-end-str-or-func - :accessor list-end-str-or-func) + (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-str-or-func :type (or string function null) :initform nil :initarg :obj-start-str-or-func - :accessor obj-start-str-or-func) + (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-str-or-func :type (or string function null) :initform nil :initarg :obj-end-str-or-func - :accessor obj-end-str-or-func) + (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) (obj-data-indent :initform nil :initarg :obj-data-indent :accessor obj-data-indent) - (obj-data-func :type (or function null) :initform nil - :initarg :obj-data-func - :accessor obj-data-func) + (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) @@ -72,15 +69,16 @@ (link-slots :type list :initform nil :documentation "List of slot names that have hyperlinks" :accessor link-slots) - (link-page-name :type (or string null) :initform nil :initarg :link-page-name - :accessor link-page-name) + (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-name "disp-func1") + (:default-initargs :link-page "disp-func1") (:documentation "View class for a hyperobject")) @@ -134,7 +132,7 @@ :category :compact-text))) view)) ((consp view-def) - (eval `(make-instance ,view-def))) + (apply #'make-instance 'object-view view-def)) (t (error "Invalid parameter to make-object-view: ~S" view-def)))) @@ -177,12 +175,10 @@ (let* ((slot-data (slot-value obj name)) (fmt-data (if formatter (funcall formatter slot-data) - slot-data)) - (data (if cdata - (kmrcl:xml-cdata fmt-data) - fmt-data))) - (write-simple data strm))) - + 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)) (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 " " 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)) - (namestr-lower (string-downcase (symbol-name name))) - (xml-namestr (escape-xml-string namestr-lower)) - (xml-tag (escape-xml-string namestr-lower)) + (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 @@ -255,44 +251,44 @@ (vector-push-extend `(write-ho-value x ',name ',type ',formatter ,cdata s) print-func)) (:compact-text-labels - (vector-push-extend `(write-string ,namestr-lower s) print-func) + (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 namestr-lower name type formatter cdata print-func)) + (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 namestr-lower name type formatter cdata print-func)) + (ppfc-html-labels user-name name type formatter cdata print-func)) (:xhtml-labels - (ppfc-xhtml-labels xml-namestr namestr-lower name type formatter cdata print-func)) + (ppfc-xhtml-labels xml-user-name user-name name type formatter cdata print-func)) (:xml-labels - (ppfc-xml-labels xml-namestr xml-tag name type formatter cdata print-func)) + (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 namestr-lower name type formatter cdata 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 namestr-lower name type formatter cdata nlink + (ppfc-html-link-labels user-name name type formatter cdata nlink print-func) - (ppfc-html-labels namestr-lower name type formatter cdata print-func))) + (ppfc-html-labels user-name name type formatter cdata print-func))) (:xhtml-link-labels (if hyperlink - (ppfc-html-link-labels xml-namestr name type formatter cdata nlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink print-func) - (ppfc-xhtml-labels xml-tag namestr-lower name type formatter cdata + (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-namestr name type formatter cdata nlink + (ppfc-html-link-labels xml-user-name name type formatter cdata nlink print-func) - (ppfc-xml-labels xml-tag namestr-lower name type formatter cdata + (ppfc-xml-labels xml-tag user-name name type formatter cdata print-func)))))) @@ -331,12 +327,12 @@ (when (and (view-has-links-p view) (esd-hyperlink slot)) (push (slot-definition-name slot) links))) - (when (plusp (length print-func)) - (setf (obj-data-print-code view) `(lambda (x s links) - (declare (ignorable links)) - ,@(map 'list #'identity print-func))) - (setf (obj-data-func view) - (compile nil (eval (obj-data-print-code view))))) + (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))) @@ -391,7 +387,7 @@ strm)) (defun initialize-text-view (view) - (setf (list-start-str-or-func view) + (setf (list-start-printer view) (compile nil (eval '(lambda (obj nitems strm) (write-user-name-maybe-plural obj nitems strm) @@ -402,9 +398,9 @@ (setf (obj-data-end-str view) +newline-string+)) (defun html-list-start-func (obj nitems strm) - (write-string "

" strm) + (write-string "

" strm) (write-user-name-maybe-plural obj nitems strm) - (write-string ":

    " strm) (write-char #\newline strm)) @@ -414,13 +410,13 @@ (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) t) - (setf (list-start-str-or-func view) #'html-list-start-func) - (setf (list-end-str-or-func view) (format nil "
~%")) + (setf (list-start-printer view) #'html-list-start-func) + (setf (list-end-printer view) (format nil "
~%")) (setf (list-end-indent view) t) (setf (obj-start-indent view) t) - (setf (obj-start-str-or-func view) "
  • ") + (setf (obj-start-printer view) "
  • ") (setf (obj-end-indent view) t) - (setf (obj-end-str-or-func view) (format nil "
    • ~%")) + (setf (obj-end-printer view) (format nil "~%")) (setf (obj-data-indent view) nil)) (defun initialize-xhtml-view (view) @@ -428,13 +424,13 @@ (setf (file-start-str view) (format nil "~%")) (setf (file-end-str view) (format nil "~%")) (setf (list-start-indent view) t) - (setf (list-start-str-or-func view) #'html-list-start-func) - (setf (list-end-str-or-func view) (format nil "
    ~%")) + (setf (list-start-printer view) #'html-list-start-func) + (setf (list-end-printer view) (format nil "~%")) (setf (list-end-indent view) t) (setf (obj-start-indent view) t) - (setf (obj-start-str-or-func view) "
  • ") + (setf (obj-start-printer view) "
  • ") (setf (obj-end-indent view) t) - (setf (obj-end-str-or-func view) (format nil "
    • ~%")) + (setf (obj-end-printer view) (format nil "~%")) (setf (obj-data-indent view) nil)) (defun xmlformat-list-end-func (x strm) @@ -456,12 +452,12 @@ (initialize-text-view view) (setf (file-start-str view) "") ; (std-xml-header) (setf (list-start-indent view) t) - (setf (list-start-str-or-func view) #'xmlformat-list-start-func) + (setf (list-start-printer view) #'xmlformat-list-start-func) (setf (list-end-indent view) t) - (setf (list-end-str-or-func view) #'xmlformat-list-end-func) - (setf (obj-start-str-or-func view) (format nil "<~(~a~)>" (object-class-name view))) + (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 (obj-end-str-or-func view) (format nil "~%" (object-class-name view))) + (setf (obj-end-printer view) (format nil "~%" (object-class-name view))) (setf (obj-end-indent view) nil) (setf (obj-data-indent view) nil)) @@ -481,7 +477,7 @@ (defun fmt-list-start (obj view strm indent num-items) (when (list-start-indent view) (indent-spaces indent strm)) - (awhen (list-start-str-or-func view) + (awhen (list-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj num-items strm)))) @@ -490,7 +486,7 @@ (declare (ignore num-items)) (when (list-end-indent view) (indent-spaces indent strm)) - (awhen (list-end-str-or-func view) + (awhen (list-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) @@ -500,7 +496,7 @@ (defun fmt-obj-start (obj view strm indent) (when (obj-start-indent view) (indent-spaces indent strm)) - (awhen (obj-start-str-or-func view) + (awhen (obj-start-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) @@ -508,7 +504,7 @@ (defun fmt-obj-end (obj view strm indent) (when (obj-end-indent view) (indent-spaces indent strm)) - (awhen (obj-end-str-or-func view) + (awhen (obj-end-printer view) (if (stringp it) (write-string it strm) (funcall it obj strm)))) @@ -516,50 +512,57 @@ ;;; Object Data -(defun make-link-start (view fieldfunc fieldvalue refvars) +(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) - (write-string (make-url (link-page-name view)) 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)) + (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)) (link-href-end view)) -(defun fmt-obj-data (obj view strm indent refvars) +(defun fmt-obj-data (obj view strm indent refvars link-printer) (when (obj-data-indent view) (indent-spaces indent strm)) (if (link-slots view) - (fmt-obj-data-with-link obj view strm refvars) + (fmt-obj-data-with-link obj view strm refvars link-printer) (fmt-obj-data-plain obj view strm)) (awhen (obj-data-end-str view) (write-string it strm))) (defun fmt-obj-data-plain (obj view strm) - (awhen (obj-data-func view) + (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 (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)) + (append (link-parameters it) refvars) + link-printer) refvalues) (push (make-link-end obj view name) refvalues))) - (funcall (obj-data-func view) obj strm (nreverse 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" @@ -577,9 +580,8 @@ objs) (defun view-hyperobject (objs view category strm &optional (indent 0) filter - subobjects refvars) + subobjects refvars link-printer) "Display a single or list of hyperobject-class instances and their subobjects" - (declare (fixnum indent)) (let-when (objlist (mklist objs)) (let ((nobjs (length objlist)) (*print-pretty* nil) @@ -592,21 +594,23 @@ (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) + (fmt-obj-data obj view strm (1+ indent) refvars link-printer) (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) + (view-hyperobject it + (get-category-view (car (mklist it)) + category) category strm (1+ indent) filter - subobjects refvars)))) + subobjects refvars link-printer)))) (fmt-obj-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))) @@ -614,7 +618,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 category stream 0 filter subobjects refvars + link-printer) (when file-wrapper (fmt-file-end view stream))) objs)