X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=07548e740fa0f8ddbb1c2e4356d2ae9f0e19d5e1;hp=dab8c16d975852736ab82c0100a0114dbbd1bd20;hb=5ab89e5feddfcb04a762cc3033c5c21f9a1d44b7;hpb=0f37aaf4b8b559025d0ea7f38754d04712fd5541 diff --git a/htmlgen.lisp b/htmlgen.lisp index dab8c16..07548e7 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.12 2003/07/13 04:56:12 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 @@ -68,7 +68,7 @@ ;; 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 @@ -84,8 +84,9 @@ (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))))) @@ -143,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 @@ -164,48 +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) - 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*))))) @@ -238,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) @@ -268,14 +306,14 @@ 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)))))) @@ -811,3 +849,27 @@ (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"))))) +