X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=607e0d2a440614bf8def35f9270189e9bb9c81f1;hb=19cb24908d2ba2faec3afbdd180eed0c7d7d8515;hp=4b0867e0ca5ec3b19cb40e2f9467a9f6854ef654;hpb=fb79a796c6ff0b90aedc377a804b48a7b543f65b;p=hyperobject.git

diff --git a/views.lisp b/views.lisp
index 4b0867e..607e0d2 100644
--- a/views.lisp
+++ b/views.lisp
@@ -7,15 +7,12 @@
 ;;;; Programmer:    Kevin M. Rosenberg
 ;;;; Date Started:  Apr 2000
 ;;;;
-;;;; $Id: views.lisp,v 1.47 2003/05/22 21:03:52 kevin Exp $
+;;;; $Id: views.lisp,v 1.54 2003/06/12 16:37:44 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 ()
@@ -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"))
 
 
@@ -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 "<span class=\"" s) print-func)
@@ -237,9 +233,9 @@
 (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))))))
 
 
@@ -333,7 +329,7 @@
 
     (vector-push-extend 'x print-func) ;; return object
     (setf (obj-data-print-code view) `(lambda (x s links)
-				       (declare (ignorable links))
+				       (declare (ignorable s links))
 				       ,@(map 'list #'identity print-func)))
     (setf (obj-data-printer view)
 	  (compile nil (eval (obj-data-print-code view))))
@@ -516,32 +512,37 @@
 ;;; 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)))
@@ -550,13 +551,15 @@
   (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-printer view) obj strm (nreverse refvalues))))
@@ -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)