From: Kevin M. Rosenberg Date: Tue, 15 Jul 2003 16:52:23 +0000 (+0000) Subject: r5308: *** empty log message *** X-Git-Tag: v1.6.2~41 X-Git-Url: http://git.kpe.io/?p=lml2.git;a=commitdiff_plain;h=5ab89e5feddfcb04a762cc3033c5c21f9a1d44b7 r5308: *** empty log message *** --- diff --git a/htmlgen.lisp b/htmlgen.lisp index 711fcc6..07548e7 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.13 2003/07/15 04:28:56 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 @@ -144,6 +144,64 @@ (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 @@ -165,74 +223,26 @@ (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) - elseif (eq :fformat (car xx)) - then - ;; process :fformat - (unless (and (listp (cadr xx)) - (>= (length (cadr xx)) 2)) - (error ":fformat must be given a list")) - (push - `(write-string - ,(format nil " ~(~a~)=\"" (car (cadr xx))) - *html-stream*) - res) - (push - `(fformat *html-stream* ,(cadr (cadr xx)) - ,@(cddr (cadr xx))) - res) - (push '(write-char #\" *html-stream*) res) - elseif (eq :optional (car xx)) - then - (push - `(when ,(cadr (cadr xx)) - (write-string - ,(format nil " ~(~a~)=\"" (car (cadr xx))) - *html-stream*) - (fformat *html-stream* "~A\"" - ,(cadr (cadr xx)))) - res) - 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 "" 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 "" 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*))))) @@ -265,14 +275,15 @@ (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) @@ -295,14 +306,14 @@ then (setq cvt "&") elseif (eq ch #\") then (setq cvt """)) - (if* cvt - then ; must do a conversion, emit previous chars first - - (when (< start i) - (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))))))