From e34bf03b10157e5594b3000be9aa6e3cedc44542 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 16 May 2003 07:35:48 +0000 Subject: [PATCH] r4966: Auto commit for Debian build --- debian/changelog | 12 ++++ rules.lisp | 4 +- views.lisp | 139 +---------------------------------------------- 3 files changed, 16 insertions(+), 139 deletions(-) diff --git a/debian/changelog b/debian/changelog index b2f5f80..7d24471 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,15 @@ +cl-hyperobject (2.8.4-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Fri, 16 May 2003 01:33:12 -0600 + +cl-hyperobject (2.8.3-1) unstable; urgency=low + + * New upstream version + + -- Kevin M. Rosenberg Thu, 15 May 2003 23:57:32 -0600 + cl-hyperobject (2.8.2-1) unstable; urgency=low * Use hash-table based ensure-lazy-reader for Allegro/SCL diff --git a/rules.lisp b/rules.lisp index 13300a5..10a8b9b 100644 --- a/rules.lisp +++ b/rules.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: rules.lisp,v 1.42 2003/05/15 20:34:03 kevin Exp $ +;;;; $Id: rules.lisp,v 1.43 2003/05/16 07:35:09 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -65,6 +65,7 @@ ;;#-ho-no-svuc +#| (defmethod (setf slot-value-using-class) :around (new-value (cl hyperobject-class) obj (slot hyperobject-esd)) @@ -82,3 +83,4 @@ (call-next-method) (when (direct-rules cl) (fire-class-rules cl obj slot))))))) +|# diff --git a/views.lisp b/views.lisp index d5536ce..6c7b9fa 100644 --- a/views.lisp +++ b/views.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: views.lisp,v 1.44 2003/05/14 21:18:12 kevin Exp $ +;;;; $Id: views.lisp,v 1.45 2003/05/16 07:35:09 kevin Exp $ ;;;; ;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg ;;;; ************************************************************************* @@ -373,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 -- 2.34.1