X-Git-Url: http://git.kpe.io/?p=hyperobject.git;a=blobdiff_plain;f=views.lisp;h=f44f800ac352f93834959b600ef07459ea581d8e;hp=4226fbc11dec52e38e31b0f48c21b0a425fd68b6;hb=4675e305339bd8b9f4cc15eb5f2da6036907a301;hpb=21df7d02d5462941859f918f4620de93e8c8f72c

diff --git a/views.lisp b/views.lisp
index 4226fbc..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.27 2003/04/16 19:35:35 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
 ;;;;
@@ -41,43 +41,35 @@
 		   :accessor file-start-str)
    (file-end-str :type (or string null) :initform nil :initarg :file-end-str
 		 :accessor file-end-str)
-   (list-start-fmtstr :type (or string null) :initform nil :initarg :list-start-fmtstr
-		      :accessor list-start-fmtstr)
-   (list-start-value-func :type (or function symbol null) :initform nil
-			  :initarg :list-start-value-func
-			  :accessor list-start-value-func)
+   (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-indent :initform nil :initarg :list-start-indent
 		      :accessor list-start-indent)
-   (list-end-fmtstr :type (or string null) :initform nil :initarg :list-end-fmtstr
-		    :accessor list-end-fmtstr)
-   (list-end-value-func :type (or function symbol null) :initform nil
-			:initarg :list-end-value-func
-			:accessor list-end-value-func)
+   (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-indent :initform nil :initarg :list-end-indent
 		    :accessor list-end-indent)
-   (obj-start-fmtstr :type (or string symbol null) :initform nil :initarg :obj-start-fmtstr
-		     :accessor obj-start-fmtstr)
-   (obj-start-value-func :initform nil :initarg :obj-start-value-func
-			 :accessor obj-start-value-func)
+   (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-indent :initform nil :initarg :obj-start-indent
 		     :accessor obj-start-indent)
-   (obj-end-fmtstr :type (or string null) :initform nil :initarg :obj-end-fmtstr
-		   :accessor obj-end-fmtstr)
-   (obj-end-value-func :type (or function symbol null) :initform nil
-		       :initarg :obj-end-value-func
-		       :accessor obj-end-value-func)
+   (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-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-fmtstr :type (or string null) :initform nil :initarg :obj-data-fmtstr
-		    :accessor obj-data-fmtstr)
-   (obj-data-end-fmtstr :type (or string null) :initform nil
-			:initarg :obj-data-end-fmtstr
-			:accessor obj-data-end-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)
    (link-slots :type list :initform nil
 	       :documentation "List of slot names that have hyperlinks"
 	       :accessor link-slots)
@@ -170,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 "<span class=\"" s) print-func)
+  (vector-push-extend `(write-string ,title s) 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 "</span>" 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)
+  (vector-push-extend `(write-string ,tag s) print-func)
+  (vector-push-extend '(write-char #\> s) print-func))
+
+(defun ppfc-html-labels (label name type formatter cdata print-func)
+  (vector-push-extend '(write-string "<span class=\"label\">" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</span> " 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 "<span class=\"label\">" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</span> " 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 "<label>" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</label> " 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)
+  (vector-push-extend `(write-string (nth ,(+ nlink nlink 1) links) s) print-func) 
+  (vector-push-extend '(write-char #\> s) print-func))
+
+(defun ppfc-html-link-labels (label name type formatter cdata nlink print-func)
+  (vector-push-extend '(write-string "<label>" s) print-func)
+  (vector-push-extend `(write-string ,label s) print-func)
+  (vector-push-extend '(write-string "</label> " 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) "&amp;"))
+    ((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) "&amp;"))
+    ((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) "&amp;"))))
+
+#+ignore
 (defun initialize-view-by-category (obj-cl view)
   "Initialize a view based upon a preset category"
   (let ((fmtstr nil)
@@ -263,7 +458,7 @@
 			   :xhtml-link-labels :xml-link-labels :ie-xml-link
 			   :ie-xml-link-labels)
 		       (or print-formatter
-			   (string-equal (write-to-string type) "string")))
+			   (lisp-type-is-a-string type)))
 	      (setq func `(kmrcl:xml-cdata ,func)))
 	    (push func value-func))
 	  )))
@@ -314,38 +509,37 @@
 (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))
-
-(defun htmlformat-list-start-value-func (x nitems) 
-  (values (hyperobject-class-user-name x) nitems (class-name-of x)))
+(defvar +newline-string+ (format nil "~%"))
 
 (defun initialize-text-view (view)
-  (setf (list-start-fmtstr view) "~a~P:~%")
-  (setf (list-start-value-func view) #'text-list-start-value-func)
+  (setf (list-start-str-or-func view)
+	(compile nil
+		 #'(lambda (obj nitems strm)
+		     (format strm "~a~P:~%"
+			     (hyperobject-class-user-name obj) nitems))))
   (setf (list-start-indent view) t)
   (setf (obj-data-indent view) t)
-  (setf (obj-data-end-fmtstr view) (format nil "~%"))
-  )
+  (setf (obj-data-end-str view) +newline-string+))
+
+(defun html-list-start-func (obj nitems strm)
+  (format strm "<p><b>~a~p:</b></p><div class=\""
+	  (hyperobject-class-user-name obj) nitems)
+  (write-string (class-name-of obj) strm)
+  (write-string "\"><ul>" strm)
+  (write-char #\newline strm))
 
 (defun initialize-html-view (view)
   (initialize-text-view view)
   (setf (file-start-str view) (format nil "<html><body>~%"))
   (setf (file-end-str view) (format nil "</body><html>~%"))
   (setf (list-start-indent view) t)
-  (setf (list-start-fmtstr view)
-	"<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%")
-  (setf (list-start-value-func view)
-	#'htmlformat-list-start-value-func)
-  (setf (list-end-fmtstr view) (format nil "</ul></div>~%"))
+  (setf (list-start-str-or-func view) #'html-list-start-func)
+  (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
   (setf (list-end-indent view) t)
-  (setf (list-end-value-func view) nil)
   (setf (obj-start-indent view) t)
-  (setf (obj-start-fmtstr view) "<li>")
-  (setf (obj-start-value-func view) nil)
+  (setf (obj-start-str-or-func view) "<li>")
   (setf (obj-end-indent view)  t)
-  (setf (obj-end-fmtstr view)  (format nil "</li>~%"))
-  (setf (obj-end-value-func view) nil)
+  (setf (obj-end-str-or-func view)  (format nil "</li>~%"))
   (setf (obj-data-indent view) t))
 
 (defun initialize-xhtml-view (view)
@@ -353,40 +547,39 @@
   (setf (file-start-str view) (format nil "<html><body>~%"))
   (setf (file-end-str view) (format nil "</body><html>~%"))
   (setf (list-start-indent view) t)
-  (setf (list-start-fmtstr view)
-	"<p><b>~a~p:</b></p><div class=\"~A\"><ul>~%")
-  (setf (list-start-value-func view)
-		    #'htmlformat-list-start-value-func)
-  (setf (list-end-fmtstr view) (format nil "</ul></div>~%"))
+  (setf (list-start-str-or-func view) #'html-list-start-func)
+  (setf (list-end-str-or-func view) (format nil "</ul></div>~%"))
   (setf (list-end-indent view) t)
-  (setf (list-end-value-func view) nil)
   (setf (obj-start-indent view) t)
-  (setf (obj-start-fmtstr view) "<li>")
-  (setf (obj-start-value-func view) nil)
+  (setf (obj-start-str-or-func view) "<li>")
   (setf (obj-end-indent view)  t)
-  (setf (obj-end-fmtstr view) (format nil "</li>~%"))
-  (setf (obj-end-value-func view) nil)
+  (setf (obj-end-str-or-func view) (format nil "</li>~%"))
   (setf (obj-data-indent view) t))
 
-(defun xmlformat-list-end-value-func (x)
-  (format nil "~alist" (class-name-of x)))
+(defun xmlformat-list-end-func (x strm)
+  (write-string "</" strm)
+  (write-string (class-name-of x) strm)
+  (write-string "list" strm)
+  (write-string ">" strm)
+  (write-char #\newline strm))
 
-(defun xmlformat-list-start-value-func (x nitems) 
-  (values (format nil "~alist" (class-name-of x)) (hyperobject-class-user-name x) nitems))
+(defun xmlformat-list-start-func (x nitems strm)
+  (write-char #\< strm)
+  (write-string (class-name-of x) strm)
+  (write-string "list><title>" strm)
+  (format strm "~A~P:</title> ~%"
+	  (hyperobject-class-user-name x) nitems))
 
 (defun initialize-xml-view (view)
   (initialize-text-view view)
   (setf (file-start-str view) "") ; (std-xml-header)
   (setf (list-start-indent view)  t)
-  (setf (list-start-fmtstr view) "<~a><title>~a~p:</title> ~%")
-  (setf (list-start-value-func view)
-	#'xmlformat-list-start-value-func)
+  (setf (list-start-str-or-func view) #'xmlformat-list-start-func)
   (setf (list-end-indent view) t)
-  (setf (list-end-fmtstr view) "</~a>~%")
-  (setf (list-end-value-func view) #'xmlformat-list-end-value-func)
-  (setf (obj-start-fmtstr view) (format nil "<~(~a~)>" (object-class-name view)))
+  (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 (obj-start-indent view) t)
-  (setf (obj-end-fmtstr view) (format nil "</~(~a~)>~%" (object-class-name view)))
+  (setf (obj-end-str-or-func view) (format nil "</~(~a~)>~%" (object-class-name view)))
   (setf (obj-end-indent view) nil)
   (setf (obj-data-indent view) nil))
 
@@ -406,42 +599,37 @@
 (defun fmt-list-start (obj view strm indent num-items)
   (when (list-start-indent view)
     (indent-spaces indent strm))
-  (let-when (fmtstr (list-start-fmtstr view))
-	    (let-if (value-func (list-start-value-func view))
-		    (apply #'format strm fmtstr
-			   (multiple-value-list (funcall value-func
-							 obj num-items)))
-		    (write-string fmtstr strm))))
+  (awhen (list-start-str-or-func view)
+	 (if (stringp it)
+	     (write-string it strm)
+	     (funcall it obj num-items strm))))
 
 (defun fmt-list-end (obj view strm indent num-items)
   (declare (ignore num-items))
   (when (list-end-indent view)
       (indent-spaces indent strm))
-  (let-when (fmtstr (list-end-fmtstr view))
-	    (let-if (value-func (list-end-value-func view))
-		    (apply #'format strm fmtstr (multiple-value-list
-						 (funcall value-func obj)))
-		    (write-string fmtstr strm))))
+  (awhen (list-end-str-or-func 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 (obj-start-indent view)
     (indent-spaces indent strm))
-  (let-when (fmtstr (obj-start-fmtstr view))
-	    (let-if (value-func (obj-start-value-func view))
-		    (apply #'format strm fmtstr (multiple-value-list
-						 (funcall value-func obj)))
-		    (write-string fmtstr strm))))
+  (awhen (obj-start-str-or-func view)
+	 (if (stringp it)
+	     (write-string it strm)
+	     (funcall it obj strm))))
 
 (defun fmt-obj-end (obj view strm indent)
   (when (obj-end-indent view)
     (indent-spaces indent strm))
-  (let-when (fmtstr (obj-end-fmtstr view))
-	    (let-if (value-func (obj-end-value-func view))
-		    (apply #'format strm fmtstr (multiple-value-list
-						 (funcall value-func obj)))
-		    (write-string fmtstr strm))))
+  (awhen (obj-end-str-or-func view)
+	 (if (stringp it)
+	     (write-string it strm)
+	     (funcall it obj strm))))
   
 ;;; Object Data 
 
@@ -470,38 +658,27 @@
   (if (link-slots view)
       (fmt-obj-data-with-link obj view strm refvars)
       (fmt-obj-data-plain obj view strm))
-  (awhen (obj-data-end-fmtstr view)
+  (awhen (obj-data-end-str view)
 	 (write-string it strm)))
 
 (defun fmt-obj-data-plain (obj view strm)
-  (awhen (obj-data-value-func view)
-	 (apply #'format strm (obj-data-fmtstr view)
-		(multiple-value-list (funcall it obj)))))
+  (awhen (obj-data-func view)
+	 (funcall it obj strm nil)))
 
 (defun fmt-obj-data-with-link (obj view strm refvars)
   (let ((refvalues '()))
     ;; make list of hyperlink link fields for printing to refstr template
     (dolist (name (link-slots view))
-      (let-when (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)))
+      (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))
+		   refvalues)
+	     (push (make-link-end obj view name) refvalues)))
+    (funcall (obj-data-func view) obj strm (nreverse refvalues))))
 
 (defun obj-data (obj view)
   "Returns the objects data as a string. Used by common-graphics outline function"
-  (awhen (obj-data-value-func view)
-	 (apply #'format nil (funcall (obj-data-fmtstr view))
-		(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 (obj-data-value-func view)
-	 (apply #'format nil (obj-data-fmtstr view)
-		(multiple-value-list (funcall it obj)))))
+  (with-output-to-string (s) (fmt-obj-data-plain obj view s)))
 
 ;;; Display method for objects