X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=views.lisp;h=ff663879499291991203436203cc34b57c8e95cd;hb=25adaa0b17882319a8e772a33f346cc6e4aaf031;hp=c53a90069ccc5ab5894413e1ea8bcce623abc7be;hpb=936bbfecd171bf0ebcbb5144eed4568f3e3aee71;p=hyperobject.git diff --git a/views.lisp b/views.lisp index c53a900..ff66387 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.15 2002/12/13 08:41:25 kevin Exp $ +;;;; $Id: views.lisp,v 1.20 2002/12/27 03:21:25 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg ;;;; @@ -26,9 +26,9 @@ :documentation "List of effective slots for object to be viewed.") (name :initform nil :initarg :name :accessor name :documentation "Name for this view.") - (category :initform nil :initarg :category :reader category + (category :initform nil :initarg :category :accessor category :documentation "Category for view. Helpful when want to find a view corresponding to a particular category.") - (source-code :initform nil :initarg :source-code + (source-code :initform nil :initarg :source-code :accessor source-code :documentation "Source code for generating view.") (country-language :initform :en :initarg :country-language :documentation "Country's Language for this view.") @@ -146,21 +146,50 @@ (defun initialize-view (obj-cl view) "Calculate all view slots for a hyperobject class" + (cond + ((category view) + (initialize-view-by-category obj-cl view)) + ((source-code view) + (initialize-view-by-source-code obj-cl view)) + (t + (setf (category view) :compact-text) + (initialize-view-by-category obj-cl view)))) + +(defun initialize-view-by-source-code (obj-cl view) + "Initialize a view based upon a source code" + (let ((source-code (source-code view))) + (error "not implemented") + ) + ) + + +(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 (slot-definition-name slot)))) - (type (slot-value slot 'type)) - (print-formatter (esd-print-formatter slot))) + (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 @@ -186,22 +215,22 @@ (string-append fmtstr (concatenate 'string "" value-fmt ""))) (:xml (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt ""))) - (:html-label + (:html-labels (string-append fmtstr (concatenate 'string "" namestr-lower " " value-fmt ""))) - (:xhtml-label - (string-append fmtstr (concatenate 'string " " value-fmt ""))) + (:xhtml-labels + (string-append fmtstr (concatenate 'string "" xml-namestr " " value-fmt ""))) (:xml-labels - (string-append fmtstr (concatenate 'string " <" namestr-lower ">" value-fmt ""))) + (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 "")))) - (:xml-link + ((or :xml-link :ie-xml-link) (push name links) (if (esd-hyperlink slot) (string-append fmtstr "<~~a>" value-fmt "") - (string-append fmtstr (concatenate 'string "<" namestr-lower ">" value-fmt "")))) + (string-append fmtstr (concatenate 'string "<" xml-tag ">" value-fmt "")))) (:html-link-labels (push name links) (if (esd-hyperlink slot) @@ -210,19 +239,20 @@ (:xhtml-link-labels (push name links) (if (esd-hyperlink slot) - (string-append fmtstr "<[!CDATA[" namestr-lower "]]> <~~a>" value-fmt "") - (string-append fmtstr (concatenate 'string " " value-fmt "")))) - (:xml-link-labels + (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 " <" namestr-lower ">" value-fmt ""))))) + (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 @@ -425,9 +455,7 @@ (defun make-link-end (obj view fieldname) (declare (ignore obj fieldname)) - ;;(format nil "~a" (href-end ref)) - (link-href-end view) - ) + (link-href-end view)) (defun fmt-obj-data (obj view strm indent refvars) (when (obj-data-indent view) @@ -436,7 +464,7 @@ (fmt-obj-data-with-link obj view strm refvars) (fmt-obj-data-plain obj view strm)) (awhen (obj-data-end-fmtstr view) - (format strm it))) + (write-string it strm))) (defun fmt-obj-data-plain (obj view strm) (awhen (obj-data-value-func view)