;; -*- mode: common-lisp; package: lml2 -*-
;;
-;; $Id: htmlgen.lisp,v 1.11 2003/06/29 16:21:09 kevin Exp $
+;; $Id: htmlgen.lisp,v 1.14 2003/07/15 16:52:23 kevin Exp $
;;
;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;; copyright (c) 2003 Kevin Rosenberg
;; Main changes from Allegro version:
;; - Support XHTML end tags
;; - lowercase symbol names for attributes
-;; - Add custom tags such as :jscript, :insert-file, :nbsp
+;; - Add custom tags such as :jscript, :insert-file, :load-file, :nbsp
;; - removal of if* macro -- partially complete
;;
;; This code is free software; you can redistribute it and/or
;; argsp is true if this isn't a singleton tag (i.e. it has
;; a body) .. (:tag ...) or ((:tag ...) ...)
;; body is the body if any of the form
- ;;
+ ;;
(let (spec)
(if* (setq spec (html-process-special ent))
then ; do something different
(push `(,(html-process-macro ent) :unset) res)
nil
else ; some args
- (push `(,(html-process-macro ent) ,args
- ,(process-html-forms body env))
+ (push `(,(html-process-macro ent)
+ ,args
+ ,(process-html-forms body env))
res)
nil)))))
(write-string ,close *html-stream*)))
+(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
+ (:if*
+ (push `(if* ,value
+ then (write-string ,(format nil " ~(~a~)" (third xx))
+ *html-stream*)
+ (prin1-safe-http-string ,(fourth xx)))
+ res)
+ (pop xx) (pop xx))
+ (: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))
+ (: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)
+ (push `(prin1-safe-http-string
+ (fformat nil ,(second value) ,@(cddr value)))
+ res))
+ (:optional
+ (push `(when ,(second value)
+ (write-string
+ ,(format nil " ~(~a~)" (first value))
+ *html-stream*)
+ (prin1-safe-http-string ,(second value)))
+ res))
+ (:if
+ (unless (and (listp value)
+ (>= (length value) 3)
+ (<= (length value) 4))
+ (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*)
+ (prin1-safe-http-string
+ (if ,eval-if
+ ,(third value)
+ ,(fourth value))))
+ res)))
+ (t
+ (push `(write-string ,(format nil " ~(~a~)" name) *html-stream*)
+ res)
+ (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
;; then do the body
(warn "arg list ~s isn't even" args))
- (if* args
- then `(progn (write-string ,(format nil "<~a" string-code)
- *html-stream*)
- ,@(do ((xx args (cddr xx))
- (res))
- ((null xx)
- (nreverse res))
- (if* (eq :if* (car xx))
- then ; insert following conditionally
- (push `(if* ,(cadr xx)
- then (write-string
- ,(format nil " ~(~a~)" (caddr xx))
- *html-stream*)
- (prin1-safe-http-string ,(cadddr xx)))
- res)
- (pop xx) (pop xx)
- else
-
- (push `(write-string
- ,(format nil " ~(~a~)" (car xx))
- *html-stream*)
- res)
- (push `(prin1-safe-http-string ,(cadr xx)) res)))
-
- ,(unless has-inv `(write-string " /" *html-stream*))
- (write-string ">" *html-stream*)
- ,@body
- ,(when (and body has-inv)
- `(write-string ,(format nil "</~a>" string-code)
- *html-stream*)))
- else
- (if* has-inv
- then
- `(progn (write-string ,(format nil "<~a>" string-code)
- *html-stream*)
- ,@body
- ,(when body
- `(write-string ,(format nil "</~a>" string-code)
- *html-stream*)))
- else
- `(progn (write-string ,(format nil "<~a />" string-code)
- *html-stream*)))))
+ (if args
+ `(progn (write-string ,(format nil "<~a" string-code)
+ *html-stream*)
+ ,@(process-attributes args)
+
+ ,(unless has-inv `(write-string " /" *html-stream*))
+ (write-string ">" *html-stream*)
+ ,@body
+ ,(when (and body has-inv)
+ `(write-string ,(format nil "</~a>" string-code)
+ *html-stream*)))
+ (if has-inv
+ `(progn (write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ ,@body
+ ,(when body
+ `(write-string ,(format nil "</~a>" string-code)
+ *html-stream*)))
+ `(progn (write-string ,(format nil "<~a />" string-code)
+ *html-stream*)))))
(unless (and (symbolp val)
(equal "" (symbol-name val)))
(write-char #\= *html-stream*)
- (if* (or (stringp val)
- (and (symbolp val)
- (setq val (string-downcase
- (symbol-name val)))))
- then (write-char #\" *html-stream*)
- (emit-safe *html-stream* val)
- (write-char #\" *html-stream*)
- else (prin1-safe-http val))))
+ (if (or (stringp val)
+ (and (symbolp val)
+ (setq val (string-downcase
+ (symbol-name val)))))
+ (progn
+ (write-char #\" *html-stream*)
+ (emit-safe *html-stream* val)
+ (write-char #\" *html-stream*))
+ (prin1-safe-http val))))
(defun emit-safe (stream string)
then (setq cvt "&")
elseif (eq ch #\")
then (setq cvt """))
- (if* cvt
- then ; must do a conversion, emit previous chars first
+ (when cvt
+ ;; must do a conversion, emit previous chars first
- (when (< start i)
- (write-sequence string stream :start start :end i))
- (write-string cvt stream)
-
- (setq start (1+ i))))))
+ (when (< start i)
+ (write-sequence string stream :start start :end i))
+ (write-string cvt stream)
+
+ (setq start (1+ i))))))
;; must use <!-- --> syntax
(declare (ignore ent args argsp))
`(progn
- (write-string "<script language=\"JavasSript\" type=\"text/javascript\">" *html-stream*)
+ (write-string "<script language=\"JavaScript\" type=\"text/javascript\">" *html-stream*)
(write-char #\newline *html-stream*)
(write-string "//
projects / lml2.git / blobdiff