X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=570caefee715ba1d0d064c1bb809198a6bdb789b;hp=07548e740fa0f8ddbb1c2e4356d2ae9f0e19d5e1;hb=89cf1a9e0c28e8e4707f5541b831b5025f953956;hpb=5ab89e5feddfcb04a762cc3033c5c21f9a1d44b7 diff --git a/htmlgen.lisp b/htmlgen.lisp index 07548e7..570caef 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.14 2003/07/15 16:52:23 kevin Exp $ +;; $Id: htmlgen.lisp,v 1.15 2003/07/15 19:25:28 kevin Exp $ ;; ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA ;; copyright (c) 2003 Kevin Rosenberg @@ -9,7 +9,9 @@ ;; - 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 +;; - removal of if* macro +;; - Add attribute conditions +;; - Automatic conversion to strings for attribute values ;; ;; This code is free software; you can redistribute it and/or ;; modify it under the terms of the version 2.1 of @@ -70,26 +72,28 @@ ;; 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,32 +102,36 @@ (setq form (macroexpand form env)) - (if* (atom form) - then (if* (keywordp form) - then (let ((ent (gethash form *html-process-table*))) - (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) - 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) - (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) - (error "unknown html keyword ~s" form) - (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)))) @@ -152,13 +160,6 @@ ((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)) @@ -178,12 +179,14 @@ (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)) + (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))) + res))) (:if (unless (and (listp value) (>= (length value) 3) @@ -197,6 +200,15 @@ ,(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-string ,(format nil " ~(~a~)" (first value)) + *html-stream*) + (prin1-safe-http-string ,(third value))) + res)) (t (push `(write-string ,(format nil " ~(~a~)" name) *html-stream*) res) @@ -272,9 +284,15 @@ ;; print the contents inside a string double quotes (which should ;; not be turned into "'s ;; symbols are turned into their name + ;; + ;; 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 @@ -296,23 +314,17 @@ (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 """)) + (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)))))) @@ -341,55 +353,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 - (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 - (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 - (when (consp (car form)) (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) @@ -403,21 +418,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 - (when (cdr entlist) - (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 - (setq alist (pop to-process)) - (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 @@ -426,29 +441,30 @@ (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))) (when (html-process-has-inverse ent)