From 4a7372ef4000eaaa86a987bc9668ccecf7d0489f Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 16 Oct 2002 22:02:30 +0000 Subject: [PATCH] r3072: *** empty log message *** --- ml-class.lisp | 28 +++++++++++++---------- package.lisp | 5 ++-- web-utils-aserve.lisp | 53 ++++++++++++++++++++++--------------------- 3 files changed, 45 insertions(+), 41 deletions(-) diff --git a/ml-class.lisp b/ml-class.lisp index 2376f0a..b720de0 100644 --- a/ml-class.lisp +++ b/ml-class.lisp @@ -11,7 +11,7 @@ ;;;; in Text, HTML, and XML formats. This includes hyperlinking ;;;; capability and sub-objects. ;;;; -;;;; $Id: ml-class.lisp,v 1.16 2002/10/16 17:37:18 kevin Exp $ +;;;; $Id: ml-class.lisp,v 1.17 2002/10/16 21:58:49 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -230,7 +230,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") (setq xmlvalue-func (append xmlvalue-func (list `(xml-cdata ,@plain-value-func)))) (setq xmlvalue-func (append xmlvalue-func plain-value-func))) )) - + (if value-func (setq value-func `(lambda (x) (values ,@value-func))) (setq value-func `(lambda () (values)))) @@ -401,14 +401,21 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-data-end-fmtstr "~%" :obj-data-value-func #'ml-class-value-func)) + +(defun class-name-of (obj) + (string-downcase (ml-class-name (ml-class-of obj)))) + +(defun htmlformat-list-start-value-func (x nitems) + (values (ml-class-title x) nitems (class-name-of x))) + (defclass htmlformat (textformat) () (:default-initargs :file-start-str "~%" :file-end-str "~%" :list-start-indent t - :list-start-fmtstr "

~a~P:

~%" + :list-start-fmtstr "

~a~p:

~%" :list-end-indent t :list-end-value-func #'identity :obj-start-indent t @@ -420,17 +427,14 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :obj-data-indent t :obj-data-fmtstr #'ml-class-fmtstr-html-labels :obj-data-fmtstr-labels #'ml-class-fmtstr-html-labels - :obj-data-value-func #'ml-class-value-func)) - + :obj-data-value-func #'ml-class-xmlvalue-func)) -(defun class-name-of (obj) - (string-downcase (ml-class-name (ml-class-of obj)))) (defun xmlformat-list-end-value-func (x) - (format nil "~alist" (string-downcase (ml-class-name (ml-class-of x))))) + (format nil "~alist" (class-name-of x))) (defun xmlformat-list-start-value-func (x nitems) - (values (format nil "~alist" (string-downcase (ml-class-name (ml-class-of x)))) (ml-class-title x) nitems)) + (values (format nil "~alist" (class-name-of x)) (ml-class-title x) nitems)) (defclass xmlformat (textformat) () @@ -471,7 +475,7 @@ Format is ((field-name field-lookup-func other-link-params) ...)") :fmtstr-labels #'ml-class-fmtstr-html-ref-labels :href-head "a href=" :href-end "a" - :ampersand "&")) + :ampersand "&")) (defclass xml-link-ref (link-ref) () diff --git a/package.lisp b/package.lisp index d4a772d..6c74e84 100644 --- a/package.lisp +++ b/package.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: package.lisp,v 1.5 2002/10/16 17:37:18 kevin Exp $ +;;;; $Id: package.lisp,v 1.6 2002/10/16 21:58:49 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -141,8 +141,7 @@ #:with-link #:home-link #:head - #:with-xml-page - #:with-html-page + #:with-page #:wrap-with-xml #:parse-xml-no-ws #:positions-xml-tag-contents diff --git a/web-utils-aserve.lisp b/web-utils-aserve.lisp index 74a518a..21d1b55 100644 --- a/web-utils-aserve.lisp +++ b/web-utils-aserve.lisp @@ -8,7 +8,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Apr 2000 ;;;; -;;;; $Id: web-utils-aserve.lisp,v 1.5 2002/10/16 17:37:18 kevin Exp $ +;;;; $Id: web-utils-aserve.lisp,v 1.6 2002/10/16 21:58:49 kevin Exp $ ;;;; ;;;; This file, part of KMRCL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -90,37 +90,38 @@ (setq css "http://b9.com/main.css")) (net.html.generator:html (:head - (princ-http (format nil "" css)) + (princ-http (format nil "" css)) (:title (:princ-safe title-str))))) ;;; Page wrappers -(defmacro with-xml-page (title &rest body) - `(prog1 - (progn - (net.html.generator:html - (princ-http (std-xml-header)) - (princ-http "")) - (with-tag "pagetitle" (princ-http ,title)) - ,@body) - (princ-http ""))) - -(defmacro with-html-page ((title &key css) &rest body) - `(prog1 - (progn - (print-http "") - (print-http "") - (print-http "") - (print-http "") - (head ,title :css ,css) - (print-http "") - (prog1 - ,@body - (print-http ""))) - (print-http ""))) +(defmacro with-page ((title &key css (format :html)) &rest body) + (case format + (:html + `(prog1 + (progn + (net.html.generator:html + (print-http "") + (print-http "") + (print-http "") + (print-http "") + (head ,title :css ,css) + (print-http "") + (prog1 + ,@body + (print-http "")))))) + (:xml + `(prog1 + (progn + (net.html.generator:html + (princ-http (std-xml-header)) + (princ-http "")) + (with-tag "pagetitle" (princ-http ,title)) + ,@body) + (princ-http ""))))) ;;; URL Encoding -- 2.34.1