;; -*- mode: common-lisp; package: lml2 -*-
;;
-;; $Id: htmlgen.lisp,v 1.2 2003/06/23 20:08:06 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
-;; - lowercase symbol names
+;; - Support XHTML end tags
+;; - lowercase symbol names for attributes
+;; - 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
;; modify it under the terms of the version 2.1 of
;; the GNU Lesser General Public License as published by
-;; the Free Software Foundation, as clarified by the AllegroServe
-;; prequel found in license-allegroserve.txt.
+;; the Free Software Foundation, as clarified by the LLGPL
(in-package #:lml2)
-;; html generation
-
(defstruct (html-process (:type list) (:constructor
make-html-process (key has-inverse
macro special
(defmacro html-out-stream-check (stream)
;; ensure that a real stream is passed to this function
- `(let ((.str. ,stream))
- (if* (not (streamp .str.))
- then (error "html-stream must be passed a stream object, not ~s"
- .str.))
- .str.))
+ (let ((s (gensym)))
+ `(let ((,s ,stream))
+ (unless (streamp ,s)
+ (error "html-stream must be passed a stream object, not ~s" ,s))
+ ,s)))
(defmacro html-stream (stream &rest forms)
;; 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)))))
(if* (atom form)
then (if* (keywordp form)
then (let ((ent (gethash form *html-process-table*)))
- (if* (null ent)
- then (error "unknown html keyword ~s"
- form)
- else (do-ent ent nil nil nil)))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent nil nil nil)))
elseif (stringp form)
then ; turn into a print of it
(push `(write-string ,form *html-stream*) res)
then ; (:xxx . body) form
(let ((ent (gethash first
*html-process-table*)))
- (if* (null ent)
- then (error "unknown html keyword ~s"
- form)
- else (do-ent ent nil t (cdr form))))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent nil t (cdr form))))
elseif (and (consp first) (keywordp (car first)))
then ; ((:xxx args ) . body)
(let ((ent (gethash (car first)
*html-process-table*)))
- (if* (null ent)
- then (error "unknown html keyword ~s"
- form)
- else (do-ent ent (cdr first) t (cdr form))))
+ (if (null ent)
+ (error "unknown html keyword ~s" form)
+ (do-ent ent (cdr first) t (cdr form))))
else (push form res))))))
`(progn ,@(nreverse res))))
(defun html-atom-check (args open close body)
- (if* (and args (atom args))
- then (let ((ans (case args
- (:set `(write-string ,open *html-stream*))
- (:unset `(write-string ,close *html-stream*))
- (t (error "illegal arg ~s to ~s" args open)))))
- (if* (and ans body)
- then (error "can't have a body form with this arg: ~s"
- args)
- else ans))))
+ (when (and args (atom args))
+ (let ((ans (case args
+ (:set `(write-string ,open *html-stream*))
+ (:unset `(write-string ,close *html-stream*))
+ (t (error "illegal arg ~s to ~s" args open)))))
+ (if (and ans body)
+ (error "can't have a body form with this arg: ~s" args)
+ ans))))
(defun html-body-form (open close body)
;; used when args don't matter
(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
- (if* (and args (atom args))
- then ; single arg
- (return-from html-body-key-form
- (case args
- (:set (if* has-inv
- then `(write-string ,(format nil "<~a>" string-code)
- *html-stream*)
- else `(write-string ,(format nil "<~a />" string-code)
+ (when (and args (atom args))
+ ;; single arg
+ (return-from html-body-key-form
+ (case args
+ (:set (if has-inv
+ `(write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ `(write-string ,(format nil "<~a />" string-code)
*html-stream*)))
- (:unset (if* has-inv
- then `(write-string ,(format nil "</~a>" string-code)
+ (:unset (when has-inv
+ `(write-string ,(format nil "</~a>" string-code)
*html-stream*)))
- (t (error "illegal arg ~s to ~s" args string-code)))))
+ (t (error "illegal arg ~s to ~s" args string-code)))))
- (if* (not (evenp (length args)))
- then (warn "arg list ~s isn't even" args))
+ (unless (evenp (length args))
+ (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
- ,(if* (and body has-inv)
- then `(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
- ,(if* body
- then `(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*)))))
;; print the contents inside a string double quotes (which should
;; not be turned into "'s
;; symbols are turned into their name
- (if* (and (symbolp val)
- (equal "" (symbol-name val)))
- thenret ; do nothing
- else (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))))
-
+ (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)))))
+ (progn
+ (write-char #\" *html-stream*)
+ (emit-safe *html-stream* val)
+ (write-char #\" *html-stream*))
+ (prin1-safe-http val))))
(defun emit-safe (stream string)
(start i)
(end (length string)))
((>= i end)
- (if* (< start i)
- then (write-sequence string
- stream
- :start start
- :end i)))
-
+ (when (< start i)
+ (write-sequence string stream :start start :end i)))
(let ((ch (schar string i))
(cvt ))
then (setq cvt "&")
elseif (eq ch #\")
then (setq cvt """))
- (if* cvt
- then ; must do a conversion, emit previous chars first
-
- (if* (< start i)
- then (write-sequence string
- stream
- :start start
- :end i))
- (write-string cvt stream)
+ (when cvt
+ ;; must do a conversion, emit previous chars first
- (setq start (1+ i))))))
+ (when (< start i)
+ (write-sequence string stream :start start :end i))
+ (write-string cvt stream)
+
+ (setq start (1+ i))))))
ent)
(if* (keywordp possible-kwd)
then (if* (null (setq ent (gethash possible-kwd *html-process-table*)))
- then (if* unknown
- then (return-from html-print-subst
- (funcall unknown form stream))
- else (error "unknown html tag: ~s" possible-kwd))
+ then (if unknown
+ (return-from html-print-subst
+ (funcall unknown form stream))
+ (error "unknown html tag: ~s" possible-kwd))
else ; see if we should subst
(if* (and subst
attrs
then (funcall print-handler
ent
:full
- (if* (consp (car form)) then (cdr (car form)))
+ (when (consp (car form)) (cdr (car form)))
form
subst
unknown
((null entlist) (setq alist nil))
(if* (consp (car ent))
then ; this is another alist
- (if* (cdr entlist)
- then (push (cdr entlist) to-process))
+ (when (cdr entlist)
+ (push (cdr entlist) to-process))
(setq alist ent)
(return) ; exit do*
elseif (equal key (car ent))
(if* (null alist)
then ; we need to find a new alist to process
- (if* to-process
- then (setq alist (pop to-process))
- else (return))))))
+ (if to-process
+ (setq alist (pop to-process))
+ (return))))))
(defun html-standard-print (ent cmd args form subst unknown stream)
;; the print handler for the normal html operators
else (format stream "<~a>" (html-process-key ent)))
(dolist (ff (cdr form))
(html-print-subst ff subst stream unknown)))
- (if* (html-process-has-inverse ent)
- then ; end the form
- (format stream "</~a>" (html-process-key ent))))))
+ (when (html-process-has-inverse ent)
+ ;; end the form
+ (format stream "</~a>" (html-process-key ent))))))
(named-function html-newline-function
(lambda (ent args argsp body)
(declare (ignore ent args argsp))
- (if* body
- then (error "can't have a body with :newline -- body is ~s" body))
-
+ (when body
+ (error "can't have a body with :newline -- body is ~s" body))
`(terpri *html-stream*)))
(named-function html-newline-print-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent unknown subst))
- (if* (eq cmd :set)
- then (terpri stream)
- else (error ":newline in an illegal place: ~s" form)))))
+ (if (eq cmd :set)
+ (terpri stream)
+ (error ":newline in an illegal place: ~s" form)))))
(def-special-html :princ
(named-function html-princ-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent unknown subst))
(assert (eql 2 (length form)))
- (if* (eq cmd :full)
- then (format stream "~a" (cadr form))
- else (error ":princ must be given an argument")))))
+ (if (eq cmd :full)
+ (format stream "~a" (cadr form))
+ (error ":princ must be given an argument")))))
(def-special-html :princ-safe
(named-function html-princ-safe-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent unknown subst))
(assert (eql 2 (length form)))
- (if* (eq cmd :full)
- then (emit-safe stream (format nil "~a" (cadr form)))
- else (error ":princ-safe must be given an argument")))))
+ (if (eq cmd :full)
+ (emit-safe stream (format nil "~a" (cadr form)))
+ (error ":princ-safe must be given an argument")))))
(def-special-html :prin1
(named-function html-prin1-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore ent args unknown subst))
(assert (eql 2 (length form)))
- (if* (eq cmd :full)
- then (format stream "~s" (cadr form))
- else (error ":prin1 must be given an argument")))))
+ (if (eq cmd :full)
+ (format stream "~s" (cadr form))
+ (error ":prin1 must be given an argument")))))
(def-special-html :prin1-safe
(named-function html-prin1-safe-function
(lambda (ent cmd args form subst unknown stream)
(declare (ignore args ent subst unknown))
(assert (eql 2 (length form)))
- (if* (eq cmd :full)
- then (emit-safe stream (format nil "~s" (cadr form)))
- else (error ":prin1-safe must be given an argument")))))
+ (if (eq cmd :full)
+ (emit-safe stream (format nil "~s" (cadr form)))
+ (error ":prin1-safe must be given an argument")))))
(def-special-html :comment
(named-function html-comment-function
;; 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 "//![CDATA[" *html-stream*)
(write-char #\newline *html-stream*)
(declare (ignore ent cmd args subst unknown))
(format stream "<script language=\"JavaScript\" type=\"text/javascript\">~%//![CDATA[~%~A~%//]]>~%</script>"
(cadr form)))))
+
+(def-special-html :nbsp
+ (named-function html-nbsp-function
+ (lambda (ent args argsp body)
+ (declare (ignore ent args argsp))
+ (when body
+ (error "can't have a body with :nbsp -- body is ~s" body))
+ `(write-string " " *html-stream*)))
+
+ (named-function html-nbsp-print-function
+ (lambda (ent cmd args form subst unknown stream)
+ (declare (ignore args ent unknown subst))
+ (if (eq cmd :set)
+ (write-string " " stream)
+ (error ":nbsp in an illegal place: ~s" form)))))
+
+
+(def-special-html :load-file
+ (named-function html-nbsp-function
+ (lambda (ent args argsp body)
+ (declare (ignore ent args argsp))
+ (unless body
+ (error "must have a body with :load-file"))
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(lml-load ,bod))
+ body))))
+
+ (named-function html-nbsp-print-function
+ (lambda (ent cmd args form subst unknown stream)
+ (declare (ignore ent unknown subst stream args))
+ (assert (eql 2 (length form)))
+ (if (eq cmd :full)
+ (lml-load (cadr form))
+ (error ":load-file must be given an argument")))))
+
+(def-special-html :insert-file
+ (named-function html-nbsp-function
+ (lambda (ent args argsp body)
+ (declare (ignore ent args argsp))
+ (unless body
+ (error "must have a body with :insert-file"))
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(insert-file ,bod))
+ body))))
+
+ (named-function html-nbsp-print-function
+ (lambda (ent cmd args form subst unknown stream)
+ (declare (ignore ent unknown subst stream args))
+ (assert (eql 2 (length form)))
+ (if (eq cmd :full)
+ (insert-file (cadr form))
+ (error ":insert-file must be given an argument")))))
+
+(def-special-html :write-string
+ (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))))
+
+ (named-function html-write-string-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)
+ (write-string (cadr form) stream)
+ (error ":write-string must be given an argument")))))
+
+(def-special-html :write-char
+ (named-function html-write-char-function
+ (lambda (ent args argsp body)
+ (declare (ignore ent args argsp))
+ `(progn ,@(mapcar #'(lambda (bod)
+ `(write-char ,bod *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)
+ (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