From 4675e305339bd8b9f4cc15eb5f2da6036907a301 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 14 May 2003 04:28:09 +0000 Subject: [PATCH] r4920: Auto commit for Debian build --- base-class.lisp | 7 +- views.lisp | 250 ++++++++++++++++++++++++++++++++++++++++++------ 2 files changed, 224 insertions(+), 33 deletions(-) diff --git a/base-class.lisp b/base-class.lisp index 47085cc..417cbcc 100644 --- a/base-class.lisp +++ b/base-class.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: base-class.lisp,v 1.5 2003/05/13 15:53:21 kevin Exp $ +;;;; $Id: base-class.lisp,v 1.6 2003/05/14 04:28:09 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -24,8 +24,5 @@ (defmethod print-object ((obj hyperobject) (s stream)) (print-unreadable-object (obj s :type t :identity t) - (let ((view (get-category-view obj :compact-text))) - - (multiple-value-call #'format s (obj-data-fmtstr view) - (funcall (obj-data-value-func view) obj))))) + (funcall (obj-data-func (get-category-view obj :compact-text)) obj s nil))) diff --git a/views.lisp b/views.lisp index 2286d9b..f44f800 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.32 2003/05/13 23:10:44 kevin Exp $ +;;;; $Id: views.lisp,v 1.33 2003/05/14 04:28:09 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -61,11 +61,12 @@ :accessor obj-end-indent) (obj-data-indent :initform nil :initarg :obj-data-indent :accessor obj-data-indent) - (obj-data-fmtstr :type (or string null) :initform nil :initarg :obj-data-fmtstr - :accessor obj-data-fmtstr) - (obj-data-value-func :type (or function symbol null) :initform nil - :initarg :obj-data-value-func - :accessor obj-data-value-func) + (obj-data-func :type (or function null) :initform nil + :initarg :obj-data-func + :accessor obj-data-func) + (obj-data-print-code :type (or function null) :initform nil + :initarg :obj-data-print-code + :accessor obj-data-print-code) (obj-data-end-str :type (or string null) :initform nil :initarg :obj-data-end-str :accessor obj-data-end-str) @@ -161,6 +162,209 @@ ) +(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)) + (data (if cdata + (kmrcl:xml-cdata fmt-data) + fmt-data))) + (typecase data + (string + (write-string data strm)) + (number + (write-string (write-to-string data) strm)) + (t + (format strm "~A" data))))) + +(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) + (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) + (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)) + (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 + (:compact-text + (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-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)) + (:xml + (ppfc-xml xml-tag name type formatter cdata print-func)) + (:html-labels + (ppfc-html-labels namestr-lower name type formatter cdata print-func)) + (:xhtml-labels + (ppfc-xhtml-labels xml-namestr namestr-lower name type formatter cdata print-func)) + (:xml-labels + (ppfc-xml-labels xml-namestr 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))) + ((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-labels namestr-lower name type formatter cdata print-func))) + (:xhtml-link-labels + (if hyperlink + (ppfc-html-link-labels xml-namestr name type formatter cdata nlink + print-func) + (ppfc-xhtml-labels xml-tag namestr-lower 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 + print-func) + (ppfc-xml-labels xml-tag namestr-lower 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-links-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 + :xml :xml-labels :xml-link :ie-xml-link + :xml-link-labels :ie-xml-link-labels) + (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))) + + (setf (obj-data-print-code view) `(lambda (x s links) + (declare (ignorable links)) + ,@(map 'list #'identity print-func))) + + (setf (obj-data-func view) + (when print-func (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 :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 (link-href-start view) "a href=") + (setf (link-href-end view) "a") + (setf (link-ampersand view) "&")) + ((or :xhtml-link :xhtml-link-labels) + (initialize-html-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) "&")))) + +#+ignore (defun initialize-view-by-category (obj-cl view) "Initialize a view based upon a preset category" (let ((fmtstr nil) @@ -320,8 +524,9 @@ (defun html-list-start-func (obj nitems strm) (format strm "

~a~p: