X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=ade02768dcec83f390dd072151da943b6fa236d7;hp=e315b270368f24f7907d58372b851bce5dd39a4f;hb=6ec49bfd3b5c1d91421258e9452ce38f99f49681;hpb=f967b95ae5fd411a19f07fff49c0ba451471e4b0 diff --git a/htmlgen.lisp b/htmlgen.lisp index e315b27..ade0276 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -1,26 +1,28 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.3 2003/06/24 01:12:17 kevin Exp $ +;; $Id: htmlgen.lisp,v 1.17 2003/07/21 16:20:47 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 +;; - 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 ;; 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 @@ -43,15 +45,54 @@ (defmacro html (&rest forms &environment env) ;; just emit html to the current stream - (process-html-forms forms env)) + ;;(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 combining 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)) + (t + (cond + ((eq (car form) 'cl:write-string) + (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 form res))))))))) + (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) @@ -69,27 +110,30 @@ ;; 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 (funcall spec ent args argsp body) res) - elseif (null argsp) - then ; singleton tag, just do the set - (push `(,(html-process-macro ent) :set) res) - nil - else (if* (equal args '(:unset)) - then ; ((:tag :unset)) is a special case. - ; that allows us to close off singleton tags - ; printed earlier. - (push `(,(html-process-macro ent) :unset) res) - nil - else ; some args - (push `(,(html-process-macro ent) ,args - ,(process-html-forms body env)) - res) - nil))))) - + (cond + ((setq spec (html-process-special ent)) + ;; do something different + (push (funcall spec ent args argsp body) res)) + ((null argsp) + ;; singleton tag, just do the set + (push `(,(html-process-macro ent) :set) res) + nil) + (t + (cond ((equal args '(:unset)) + ;; ((:tag :unset)) is a special case. + ;; that allows us to close off singleton tags + ;; printed earlier. + (push `(,(html-process-macro ent) :unset) res) + nil) + (t + ;; some args + (push `(,(html-process-macro ent) + ,args + ,(process-html-forms body env)) + res) + nil))))))) (do* ((xforms forms (cdr xforms)) @@ -98,48 +142,48 @@ (setq form (macroexpand form env)) - (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))) - elseif (stringp form) - then ; turn into a print of it - (push `(write-string ,form *html-stream*) res) - else (push form res)) - else (let ((first (car form))) - (if* (keywordp first) - 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)))) - 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)))) - else (push form res)))))) + (if (atom form) + (cond + ((keywordp form) + (let ((ent (gethash form *html-process-table*))) + (if (null ent) + (error "unknown html keyword ~s" form) + (do-ent ent nil nil nil)))) + ((stringp form) + ;; turn into a print of it + (push `(write-string ,form *html-stream*) res)) + (t + (push form res))) + (let ((first (car form))) + (cond + ((keywordp first) + ;; (:xxx . body) form + (let ((ent (gethash first + *html-process-table*))) + (if (null ent) + (error "unknown html keyword ~s" form) + (do-ent ent nil t (cdr form))))) + ((and (consp first) (keywordp (car first))) + ;; ((:xxx args ) . body) + (let ((ent (gethash (car first) + *html-process-table*))) + (if (null ent) + (error "unknown html keyword ~s" form) + (do-ent ent (cdr first) t (cdr form))))) + (t + (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 @@ -148,69 +192,120 @@ (write-string ,close *html-stream*))) +(defun attribute-name-string (name) + (etypecase name + (symbol (string-downcase (symbol-name name))) + (string name))) + +(defun process-attributes (args) + (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")) + (mapcar (lambda (f) (push f res)) + (write-attribute-name-forms (first value))) + (push `(prin1-safe-http-string + (format nil ,(second value) ,@(cddr value))) + res)) + (:optional + (let ((eval-if (gensym "EVAL-IF-"))) + (push `(let ((,eval-if ,(second value))) + (when ,eval-if + ,@(write-attribute-name-forms (first value)) + (prin1-safe-http-string ,eval-if))) + 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-attribute-name-forms (first value)) + (prin1-safe-http-string + (if ,eval-if + ,(third value) + ,(fourth value)))) + res))) + (:when + (unless (and (listp value) + (= (length value) 3)) + (error ":when must be given a list with 3 elements")) + (push `(when ,(second value) + ,@(write-attribute-name-forms (first value)) + (prin1-safe-http-string ,(third value))) + res)) + (t + (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 ;; 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 "" string-code) + (:unset (when has-inv + `(write-string ,(format nil "" 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 "" 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 "" 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 "" string-code) + *html-stream*))) + (if has-inv + `(progn (write-string ,(format nil "<~a>" string-code) + *html-stream*) + ,@body + ,(when body + `(write-string ,(format nil "" string-code) + *html-stream*))) + `(progn (write-string ,(format nil "<~a />" string-code) + *html-stream*))))) @@ -240,56 +335,48 @@ ;; 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)))) - + ;; + ;; non-string and non-symbols are written to a string and quoted + + (unless (and (symbolp val) + (equal "" (symbol-name val))) + (write-char #\= *html-stream*) + (when (not (or (stringp val) + (symbolp val))) + (setq val (write-to-string 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) - ;; 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))) ((>= 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 )) - (if* (eql ch #\<) - then (setq cvt "<") - elseif (eq ch #\>) - then (setq cvt ">") - elseif (eq ch #\&) - 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) - - (setq start (1+ i)))))) + (let* ((ch (schar string i)) + (cvt (case ch + (#\< "<") + (#\> ">") + (#\& "&") + (#\" """)))) + (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)))))) @@ -317,55 +404,58 @@ (let* ((attrs) (attr-name) (name) - (possible-kwd (if* (atom form) - then form - elseif (consp (car form)) - then (setq attrs (cdar form)) - (caar form) - else (car form))) + (possible-kwd (cond + ((atom form) form) + ((consp (car form)) + (setq attrs (cdar form)) + (caar form)) + (t (car form)))) print-handler 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)) - else ; see if we should subst - (if* (and subst - attrs - (setq attr-name (html-process-name-attr ent)) - (setq name (getf attrs attr-name)) - (setq attrs (html-find-value name subst))) - then - (return-from html-print-subst - (if* (functionp (cdr attrs)) - then - (funcall (cdr attrs) stream) - else (html-print-subst - (cdr attrs) - subst - stream - unknown))))) - - (setq print-handler - (html-process-print ent))) - (if* (atom form) - then (if* (keywordp form) - then (funcall print-handler ent :set nil nil nil nil stream) - elseif (stringp form) - then (write-string form stream) - else (princ form stream)) - elseif ent - then (funcall print-handler - ent - :full - (if* (consp (car form)) then (cdr (car form))) - form - subst - unknown - stream) - else (error "Illegal form: ~s" form)))) + (when (keywordp possible-kwd) + (if (null (setq ent (gethash possible-kwd *html-process-table*))) + (if unknown + (return-from html-print-subst + (funcall unknown form stream)) + (error "unknown html tag: ~s" possible-kwd)) + ;; see if we should subst + (when (and subst + attrs + (setq attr-name (html-process-name-attr ent)) + (setq name (getf attrs attr-name)) + (setq attrs (html-find-value name subst))) + (return-from html-print-subst + (if (functionp (cdr attrs)) + (funcall (cdr attrs) stream) + (html-print-subst + (cdr attrs) + subst + stream + unknown))))) + + (setq print-handler + (html-process-print ent))) + + (cond + ((atom form) + (cond + ((keywordp form) + (funcall print-handler ent :set nil nil nil nil stream)) + ((stringp form) + (write-string form stream)) + (t + (princ form stream)))) + (ent + (funcall print-handler + ent + :full + (when (consp (car form)) (cdr (car form))) + form + subst + unknown + stream)) + (t + (error "Illegal form: ~s" form))))) (defun html-find-value (key subst) @@ -379,21 +469,21 @@ (do* ((entlist alist (cdr entlist)) (ent (car entlist) (car entlist))) ((null entlist) (setq alist nil)) - (if* (consp (car ent)) - then ; this is another alist - (if* (cdr entlist) - then (push (cdr entlist) to-process)) - (setq alist ent) - (return) ; exit do* - elseif (equal key (car ent)) - then (return-from html-find-value ent))) + (cond + ((consp (car ent)) + ;; this is another alist + (when (cdr entlist) + (push (cdr entlist) to-process)) + (setq alist ent) + (return)) ; exit do* + ((equal key (car ent)) + (return-from html-find-value 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)))))) + (when (null alist) + ;; we need to find a new alist to process + (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 @@ -402,34 +492,35 @@ (format stream "<~a>" (html-process-key ent))) (:full ; set, do body and then unset (let (iter) - (if* args - then (if* (and (setq iter (getf args :iter)) - (setq iter (html-find-value iter subst))) - then ; remove the iter and pre - (setq args (copy-list args)) - (remf args :iter) - (funcall (cdr iter) - (cons (cons (caar form) - args) - (cdr form)) - subst - stream) - (return-from html-standard-print) - else - (format stream "<~a" (html-process-key ent)) - (do ((xx args (cddr xx))) - ((null xx)) - ; assume that the arg is already escaped - ; since we read it - ; from the parser - (format stream " ~a=\"~a\"" (car xx) (cadr xx))) - (format stream ">")) - else (format stream "<~a>" (html-process-key ent))) + (if args + (cond + ((and (setq iter (getf args :iter)) + (setq iter (html-find-value iter subst))) + ;; remove the iter and pre + (setq args (copy-list args)) + (remf args :iter) + (funcall (cdr iter) + (cons (cons (caar form) + args) + (cdr form)) + subst + stream) + (return-from html-standard-print)) + (t + (format stream "<~a" (html-process-key ent)) + (do ((xx args (cddr xx))) + ((null xx)) + ; assume that the arg is already escaped + ; since we read it + ; from the parser + (format stream " ~a=\"~a\"" (car xx) (cadr xx))) + (format stream ">"))) + (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 "" (html-process-key ent)))))) + (when (html-process-has-inverse ent) + ;; end the form + (format stream "" (html-process-key ent)))))) @@ -487,17 +578,16 @@ (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 @@ -511,9 +601,9 @@ (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 @@ -526,9 +616,9 @@ (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 @@ -541,9 +631,9 @@ (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 @@ -556,9 +646,9 @@ (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 @@ -728,7 +818,7 @@ ;; must use syntax (declare (ignore ent args argsp)) `(progn - (write-string "