X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=a62baf0c40c78bdc072eefaf00f1b9c25f0a65f8;hb=cda49a13fa66d935f4d7db644364cc741b9c1c4c;hp=e9a89e3cd9c9d02eef285ec640d85546ca73a5b5;hpb=aaef96a66c4f9913e88170f241a217a49078e9a9;p=hyperobject.git

diff --git a/views.lisp b/views.lisp
index e9a89e3..a62baf0 100644
--- a/views.lisp
+++ b/views.lisp
@@ -7,7 +7,7 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.2 2002/11/25 07:45:35 kevin Exp $
+;;;; $Id: views.lisp,v 1.3 2002/11/29 05:05:29 kevin Exp $
 ;;;;
 ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
 ;;;;
@@ -18,6 +18,134 @@
 (eval-when (:compile-toplevel :execute)
   (declaim (optimize (speed 3) (safety 1) (compilation-speed 0) (debug 3))))
 
+
+;;;; *************************************************************************
+;;;;  Metaclass Intialization
+;;;; *************************************************************************
+
+(defun process-views (cl)
+  "Calculate all view slots for a hyperobject class"
+  (let ((fmtstr-text "")
+	(fmtstr-html "")
+	(fmtstr-xml "")
+	(fmtstr-text-labels "")
+	(fmtstr-html-labels "")
+	(fmtstr-xml-labels "")
+	(fmtstr-html-ref "")
+	(fmtstr-xml-ref "")
+	(fmtstr-html-ref-labels "")
+	(fmtstr-xml-ref-labels "")
+	(first-field t)
+	(value-func '())
+	(xmlvalue-func '())
+	(classname (class-name cl))
+	(package (symbol-package (class-name cl)))
+	(references nil))
+    (declare (ignore classname))
+    (check-type (slot-value cl 'print-slots) list)
+    (dolist (slot-name (slot-value cl 'print-slots))
+      (let ((slot (find-slot-by-name cl slot-name)))
+	(unless slot
+	  (error "Slot ~A is not found in class ~S" slot-name cl))
+	(let ((name (slot-definition-name slot))
+	      (namestr (symbol-name (slot-definition-name slot)))
+	      (namestr-lower (string-downcase (symbol-name (slot-definition-name slot))))
+	      (type (slot-value slot 'ho-type))
+	      (print-formatter (slot-value slot 'print-formatter))
+	      (value-fmt "~a")
+	      (plain-value-func nil)
+	      html-str xml-str html-label-str xml-label-str)
+	  
+	  (when (or (eql type :integer) (eql type :fixnum))
+	    (setq value-fmt "~d"))
+	  
+	  (when (eql type :boolean)
+	    (setq value-fmt "~a"))
+	  
+	  (if first-field
+	      (setq first-field nil)
+	      (progn
+		(string-append fmtstr-text " ")
+		(string-append fmtstr-html " ")
+		(string-append fmtstr-xml " ")
+		(string-append fmtstr-text-labels " ")
+		(string-append fmtstr-html-labels " ")
+		(string-append fmtstr-xml-labels " ")
+		(string-append fmtstr-html-ref " ")
+		(string-append fmtstr-xml-ref " ")
+		(string-append fmtstr-html-ref-labels " ")
+		(string-append fmtstr-xml-ref-labels " ")))
+	  
+	  (setq html-str (concatenate 'string "<span class=\"" namestr-lower "\">" value-fmt "</span>"))
+	  (setq xml-str (concatenate 'string "<" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+	  (setq html-label-str (concatenate 'string "<span class=\"label\">" namestr-lower "</span> <span class=\"" namestr-lower "\">" value-fmt "</span>"))
+	  (setq xml-label-str (concatenate 'string "<label>" namestr-lower "</label> <" namestr-lower ">" value-fmt "</" namestr-lower ">"))
+	  
+	  (string-append fmtstr-text value-fmt)
+	  (string-append fmtstr-html html-str)
+	  (string-append fmtstr-xml xml-str)
+	  (string-append fmtstr-text-labels namestr-lower " " value-fmt)
+	  (string-append fmtstr-html-labels html-label-str)
+	  (string-append fmtstr-xml-labels xml-label-str)
+	  
+	  (if (slot-value slot 'reference)
+	      (progn
+		(string-append fmtstr-html-ref "<~~a>" value-fmt "</~~a>")
+		(string-append fmtstr-xml-ref "<~~a>" value-fmt "</~~a>")
+		(string-append fmtstr-html-ref-labels "<span class=\"label\">" namestr-lower "</span> <~~a>" value-fmt "</~~a>")
+		(string-append fmtstr-xml-ref-labels "<label>" namestr-lower "</label> <~~a>" value-fmt "</~~a>")
+		(push (make-instance 'reference :name name
+				     :lookup (slot-value slot 'reference))
+		      references))
+	      (progn
+		(string-append fmtstr-html-ref html-str)
+		(string-append fmtstr-xml-ref xml-str)
+		(string-append fmtstr-html-ref-labels html-label-str)
+		(string-append fmtstr-xml-ref-labels xml-label-str)))
+	  
+	  (if print-formatter
+	      (setq plain-value-func 
+		    (list `(,print-formatter (slot-value x ',(intern namestr package)))))
+	      (setq plain-value-func 
+		    (list `(slot-value x ',(intern namestr package)))))
+	  (setq value-func (append value-func plain-value-func))
+	  
+	  (if (eql type :cdata)
+	      (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func))))
+	      (setq xmlvalue-func (append xmlvalue-func plain-value-func)))
+	  )))
+    
+    (setf (slot-value cl 'references) references)
+    
+    (if value-func
+	(setq value-func `(lambda (x) (values ,@value-func)))
+	(setq value-func `(lambda () (values))))
+    (setq value-func (compile nil (eval value-func)))
+    
+    (if xmlvalue-func
+	(setq xmlvalue-func `(lambda (x) (values ,@xmlvalue-func)))
+	(setq xmlvalue-func `(lambda () (values))))
+    (setq xmlvalue-func (compile nil (eval xmlvalue-func)))
+    
+    (setf (slot-value cl 'fmtstr-text) fmtstr-text)
+    (setf (slot-value cl 'fmtstr-html) fmtstr-html)
+    (setf (slot-value cl 'fmtstr-xml) fmtstr-xml)
+    (setf (slot-value cl 'fmtstr-text-labels) fmtstr-text-labels)
+    (setf (slot-value cl 'fmtstr-html-labels) fmtstr-html-labels)
+    (setf (slot-value cl 'fmtstr-xml-labels) fmtstr-xml-labels)
+    (setf (slot-value cl 'fmtstr-html-ref) fmtstr-html-ref)
+    (setf (slot-value cl 'fmtstr-xml-ref) fmtstr-xml-ref)
+    (setf (slot-value cl 'fmtstr-html-ref-labels) fmtstr-html-ref-labels)
+    (setf (slot-value cl 'fmtstr-xml-ref-labels) fmtstr-xml-ref-labels)
+    (setf (slot-value cl 'value-func) value-func)
+    (setf (slot-value cl 'xmlvalue-func) xmlvalue-func))
+  (values))
+
+
+;;;; *************************************************************************
+;;;;  View Data Format Section
+;;;; *************************************************************************
+
 (defparameter *default-textformat* nil)
 (defparameter *default-htmlformat* nil)
 (defparameter *default-htmlrefformat* nil)