;; -*- mode: common-lisp; package: lml2 -*-
;;
-;; $Id: htmlgen.lisp,v 1.15 2003/07/15 19:25:28 kevin Exp $
+;; $Id$
;;
;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;; copyright (c) 2003 Kevin Rosenberg
;; - 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
)
(defmacro html (&rest forms &environment env)
- ;; just emit html to the current stream
- (process-html-forms forms env))
+ (post-process-html-forms
+ (process-html-forms forms env)))
+
+(defun post-process-html-forms (input-forms)
+ "KMR: Walk through forms and combine write-strings"
+ (let (res strs last-stream)
+ (flet ((flush-strings ()
+ (when strs
+ (push `(write-string ,strs ,last-stream) res)
+ (setq strs nil)
+ (setq last-stream nil))))
+ (do* ((forms input-forms (cdr forms))
+ (form (car forms) (car forms)))
+ ((null forms)
+ (flush-strings)
+ (nreverse res))
+ (cond
+ ((atom form)
+ (flush-strings)
+ (push form res))
+ ((and (eq (car form) 'cl:write-string)
+ (stringp (cadr form)))
+ (if strs
+ (if (eq last-stream (third form))
+ (setq strs (concatenate 'string strs (second form)))
+ (progn
+ (flush-strings)
+ (setq strs (second form))
+ (setq last-stream (third form))))
+ (progn
+ (setq strs (second form))
+ (setq last-stream (third form)))))
+ (t
+ (flush-strings)
+ (push (post-process-html-forms form) res)))))))
+
(defmacro html-out-stream-check (stream)
;; ensure that a real stream is passed to this function
(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)
(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)
(= (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
(if args
`(progn (write-string ,(format nil "<~a" string-code)
*html-stream*)
+
,@(process-attributes args)
,(unless has-inv `(write-string " /" *html-stream*))
(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)))
;; must use <!-- --> syntax
(declare (ignore ent args argsp))
`(progn
+ #+ignore
(write-string "<script language=\"JavaScript\" type=\"text/javascript\">" *html-stream*)
+ (write-string "<script type=\"text/javascript\">" *html-stream*)
(write-char #\newline *html-stream*)
- (write-string "//![CDATA[" *html-stream*)
+ (write-string "// <![CDATA[" *html-stream*)
(write-char #\newline *html-stream*)
(html ,@body)
(write-char #\newline *html-stream*)
- (write-string "//]]>" *html-stream*)
+ (write-string "// ]]>" *html-stream*)
(write-char #\newline *html-stream*)
(write-string "</script>" *html-stream*))))
(named-function html-comment-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore ent cmd args subst unknown))
- (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%//![CDATA[~%~A~%//]]>~%</script>"
+ (format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%// <![CDATA[~%~A~%// ]]>~%</script>"
(cadr form)))))
(def-special-html :nbsp
(named-function html-write-string-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
- `(progn ,@(mapcar #'(lambda (bod)
- `(write-string ,bod *html-stream*))
- body))))
+ (if (= (length body) 1)
+ `(write-string ,(car body) *html-stream*)
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(write-string ,bod *html-stream*))
+ body)))))
(named-function html-write-string-print-function
(lambda (ent cmd args form subst unknown stream)
(write-char (cadr form) stream)
(error ":write-char must be given an argument")))))
-;; fast formatter
-(def-special-html :fformat
- (named-function html-write-char-function
- (lambda (ent args argsp body)
- (declare (ignore ent args argsp))
- `(progn ,@(mapcar #'(lambda (bod)
- `(progn
- (format *html-stream* " ~(~A~)=\"" (car ,bod))
- (apply #'format *html-stream* (cdr ,bod))
- (write-char #\" *html-stream*)))
- body))))
-
- (named-function html-write-char-print-function
- (lambda (ent cmd args form subst unknown stream)
- (declare (ignore args ent unknown subst))
- (assert (eql 2 (length form)))
- (if (eq cmd :full)
- (progn
- (format stream " ~(~A~)=\"" (car form))
- (apply #'format stream (cdr form))
- (write-char #\" stream))
- (error ":fformat must be given an argument")))))
+
projects / lml2.git / blobdiff