X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=4b0867e0ca5ec3b19cb40e2f9467a9f6854ef654;hb=fb79a796c6ff0b90aedc377a804b48a7b543f65b;hp=ee6008e818e190e8bef5821b5d9d811e66afea3a;hpb=d9d94a840a96a47da55d76b641f1140991ac410c;p=hyperobject.git
diff --git a/views.lisp b/views.lisp
index ee6008e..4b0867e 100644
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
;;;; Programmer: Kevin M. Rosenberg
;;;; Date Started: Apr 2000
;;;;
-;;;; $Id: views.lisp,v 1.41 2003/05/14 07:05:24 kevin Exp $
+;;;; $Id: views.lisp,v 1.47 2003/05/22 21:03:52 kevin Exp $
;;;;
;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg
;;;; *************************************************************************
@@ -40,29 +40,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)
@@ -134,7 +134,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))))
@@ -161,9 +161,16 @@
)
(defmacro write-simple (v s)
- `(if (stringp ,v)
- (write-string ,v ,s)
- (write-string (write-to-string ,v) ,s)))
+ `(typecase ,v
+ (string
+ (write-string ,v ,s))
+ #+allegro
+ (fixnum
+ (excl::print-fixnum ,s 10 ,v))
+ (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))
@@ -272,6 +279,8 @@
(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
+ print-func)
(ppfc-html-labels namestr-lower name type formatter cdata print-func)))
(:xhtml-link-labels
(if hyperlink
@@ -289,7 +298,7 @@
(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
+ :html-link-labels :xhtml-link-labels :xml-link-labels
:ie-xml-link-labels))
(defun initialize-view-by-category (obj-cl view)
@@ -297,6 +306,7 @@
(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)
(error "Unknown view category ~A" (category view)))
@@ -321,12 +331,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 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)))
@@ -363,143 +373,6 @@
(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)
- (first-field t)
- (value-func '())
- (links '())
- (category (category view)))
-
- (unless (in category :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))
-
- (unless (slots view)
- (setf (slots view) (default-print-slots obj-cl)))
- (dolist (slot-name (slots view))
- (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 name)))
- (xml-namestr (escape-xml-string namestr-lower))
- (xml-tag (escape-xml-string namestr-lower))
- (type (slot-value slot 'type))
- (print-formatter (esd-print-formatter slot)))
-
- (cond
- (first-field
- (setq fmtstr "")
- (setq first-field nil))
- (t
- (string-append fmtstr " ")))
-
- (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-labels
- (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt "")))
- (:xhtml-labels
- (string-append fmtstr (concatenate 'string "" xml-namestr " " value-fmt "")))
- (:xml-labels
- (string-append fmtstr (concatenate 'string " <" xml-tag ">" value-fmt "")))
- ((or :html-link :xhtml-link)
- (push name links)
- (if (esd-hyperlink slot)
- (string-append fmtstr "<~~a>" value-fmt "")
- (string-append fmtstr (concatenate 'string "" value-fmt ""))))
- ((or :xml-link :ie-xml-link)
- (push name links)
- (if (esd-hyperlink slot)
- (string-append fmtstr "<~~a>" value-fmt "")
- (string-append fmtstr (concatenate 'string "<" xml-tag ">" value-fmt ""))))
- (:html-link-labels
- (push name links)
- (if (esd-hyperlink slot)
- (string-append fmtstr "" namestr-lower " <~~a>" value-fmt "")
- (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt ""))))
- (:xhtml-link-labels
- (push name links)
- (if (esd-hyperlink slot)
- (string-append fmtstr "" xml-namestr " <~~a>" value-fmt "")
- (string-append fmtstr (concatenate 'string "" xml-namestr " " value-fmt ""))))
- ((or :xml-link-labels :ie-xml-link-labels)
- (push name links)
- (if (esd-hyperlink slot)
- (string-append fmtstr " <~~a>" value-fmt "")
- (string-append fmtstr (concatenate 'string " <" xml-tag ">" 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
- :xml-labels :ie-xml-labels
- :xhtml-link-labels :xml-link-labels :ie-xml-link
- :ie-xml-link-labels)
- (or print-formatter
- (lisp-type-is-a-string type)))
- (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 (obj-data-fmtstr view) fmtstr)
- (setf (obj-data-value-func view) value-func)
- (setf (link-slots view) (nreverse links))
-
- (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 (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) "&"))))
- view)
-
;;;; *************************************************************************
;;;; View Data Format Section
@@ -518,7 +391,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)
@@ -541,28 +414,28 @@
(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-data-indent view) t))
+ (setf (obj-end-printer view) (format nil "~%"))
+ (setf (obj-data-indent view) nil))
(defun initialize-xhtml-view (view)
(initialize-text-view view)
(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-data-indent view) t))
+ (setf (obj-end-printer view) (format nil "~%"))
+ (setf (obj-data-indent view) nil))
(defun xmlformat-list-end-func (x strm)
(write-string "" (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))
@@ -608,7 +481,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))))
@@ -617,7 +490,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))))
@@ -627,7 +500,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))))
@@ -635,7 +508,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))))
@@ -674,7 +547,7 @@
(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)
@@ -686,7 +559,7 @@
(append (link-parameters it) refvars))
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"