From 90a7d4f43c8591838017738e82e3cf9383794d34 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 15 Jul 2003 21:49:36 +0000 Subject: [PATCH] r5312: *** empty log message *** --- 2/htmlgen.lisp | 78 +++++++++++++++++++++++++++++--------------------- 2/utils.lisp | 16 +++++++++-- 2 files changed, 58 insertions(+), 36 deletions(-) diff --git a/2/htmlgen.lisp b/2/htmlgen.lisp index 570caef..6a3650d 100644 --- a/2/htmlgen.lisp +++ b/2/htmlgen.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.15 2003/07/15 19:25:28 kevin Exp $ +;; $Id: htmlgen.lisp,v 1.16 2003/07/15 21:49:36 kevin Exp $ ;; ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA ;; copyright (c) 2003 Kevin Rosenberg @@ -12,6 +12,7 @@ ;; - removal of if* macro ;; - Add attribute conditions ;; - Automatic conversion to strings for attribute values +;; - Convert some comments to function doc strings ;; ;; This code is free software; you can redistribute it and/or ;; modify it under the terms of the version 2.1 of @@ -152,40 +153,51 @@ (write-string ,close *html-stream*))) +(defun attribute-name-string (name) + (etypecase name + (symbol (string-downcase (symbol-name name))) + (string name))) + (defun process-attributes (args) - (do* ((xx args (cddr xx)) - (res) - (name (first xx) (first xx)) - (value (second xx) (second xx))) - ((null xx) - (nreverse res)) - (case name - (:fformat - (unless (and (listp value) - (>= (length value) 2)) - (error ":fformat must be given a list at least 2 elements")) - (push `(write-string - ,(format nil " ~(~a~)=\"" (first value)) - *html-stream*) res) - (push - `(fformat *html-stream* ,(second value) ,@(cddr value)) res) - (push `(write-char #\" *html-stream*) res)) + (flet ((write-attribute-name-forms (name) + `((write-char #\space *html-stream*) + (write-string ,(attribute-name-string name) + *html-stream*))) + (write-separator-forms () + '((write-char #\= *html-stream*) + (write-char #\" *html-stream*)))) + (do* ((xx args (cddr xx)) + (res) + (name (first xx) (first xx)) + (value (second xx) (second xx))) + ((null xx) + (nreverse res)) + (case name + (:fformat + (unless (and (listp value) + (>= (length value) 2)) + (error ":fformat must be given a list at least 2 elements")) + (mapcar (lambda (f) (push f res)) + (write-attribute-name-forms (first value))) + (mapcar (lambda (f) (push f res)) + (write-separator-forms)) + (push `(fformat *html-stream* ,(second value) ,@(cddr value)) + res) + (push `(write-char #\" *html-stream*) res)) (:format (unless (and (listp value) (>= (length value) 2)) (error ":format must be given a list at least 2 elements")) - (push `(write-string ,(format nil " ~(~a~)" (first value)) - *html-stream*) res) + (mapcar (lambda (f) (push f res)) + (write-attribute-name-forms (first value))) (push `(prin1-safe-http-string - (fformat nil ,(second value) ,@(cddr value))) + (format nil ,(second value) ,@(cddr value))) res)) (:optional (let ((eval-if (gensym "EVAL-IF-"))) (push `(let ((,eval-if ,(second value))) (when ,eval-if - (write-string - ,(format nil " ~(~a~)" (first value)) - *html-stream*) - (prin1-safe-http-string ,eval-if))) + ,@(write-attribute-name-forms (first value)) + (prin1-safe-http-string ,eval-if))) res))) (:if (unless (and (listp value) @@ -194,7 +206,7 @@ (error ":if must be given a list with 3 and 4 elements")) (let ((eval-if (gensym "EVAL-IF-"))) (push `(let ((,eval-if ,(second value))) - (write-string ,(format nil " ~(~a~)" (first value)) *html-stream*) + ,@(write-attribute-name-forms (first value)) (prin1-safe-http-string (if ,eval-if ,(third value) @@ -205,14 +217,13 @@ (= (length value) 3)) (error ":when must be given a list with 3 elements")) (push `(when ,(second value) - (write-string ,(format nil " ~(~a~)" (first value)) - *html-stream*) + ,@(write-attribute-name-forms (first value)) (prin1-safe-http-string ,(third value))) res)) (t - (push `(write-string ,(format nil " ~(~a~)" name) *html-stream*) - res) - (push `(prin1-safe-http-string ,value) res))))) + (mapcar (lambda (f) (push f res)) + (write-attribute-name-forms name)) + (push `(prin1-safe-http-string ,value) res)))))) (defun html-body-key-form (string-code has-inv args body) ;; do what's needed to handle given keywords in the args @@ -238,6 +249,7 @@ (if args `(progn (write-string ,(format nil "<~a" string-code) *html-stream*) + ,@(process-attributes args) ,(unless has-inv `(write-string " /" *html-stream*)) @@ -305,8 +317,8 @@ (defun emit-safe (stream string) - ;; send the string to the http response stream watching out for - ;; special html characters and encoding them appropriately + "Send the string to the http response stream watching out for + special html characters and encoding them appropriately." (do* ((i 0 (1+ i)) (start i) (end (length string))) diff --git a/2/utils.lisp b/2/utils.lisp index 2a6877f..0eef8e4 100644 --- a/2/utils.lisp +++ b/2/utils.lisp @@ -7,7 +7,7 @@ ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: June 2002 ;;;; -;;;; $Id: utils.lisp,v 1.4 2003/07/15 04:28:56 kevin Exp $ +;;;; $Id: utils.lisp,v 1.5 2003/07/15 21:49:36 kevin Exp $ ;;;; ;;;; This file, part of LML2, is copyrighted and open-source software. ;;;; Rights of modification and redistribution are in the LICENSE file. @@ -73,7 +73,17 @@ #-(or allegro clisp cmu scl sbcl cormanlisp lispworks lucid mcl) (truename ".")) - +#+ignore (defun fformat (&rest args) (declare (dynamic-extent args)) - (apply #'format args)) + (apply (if (find-package 'kmrcl) + (symbol-function (intern (symbol-name #:fformat) + (symbol-name #:kmrcl))) + #'format) + args)) + +(defmacro fformat (stream control-string &rest args) + (if stream + `(funcall (formatter ,control-string) ,stream ,@args) + `(format nil ,control-string ,@args))) + -- 2.34.1