X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=07548e740fa0f8ddbb1c2e4356d2ae9f0e19d5e1;hp=46abc6d1ba5fc6451f34ac613ab9e925f6a0d576;hb=5ab89e5feddfcb04a762cc3033c5c21f9a1d44b7;hpb=8970e8949b6f85a0a66b12b660900b71699b169a diff --git a/htmlgen.lisp b/htmlgen.lisp index 46abc6d..07548e7 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.8 2003/06/24 17:57:17 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 @@ -8,7 +8,8 @@ ;; Main changes from Allegro version: ;; - Support XHTML end tags ;; - lowercase symbol names for attributes -;; - Add custom tags such as :jscript, :insert-file, :nbsp +;; - 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 @@ -67,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 @@ -83,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))))) @@ -99,10 +101,9 @@ (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) @@ -112,32 +113,29 @@ 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 @@ -146,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 @@ -153,62 +209,40 @@ ;; 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) - *html-stream*))) - (:unset (if* has-inv - then `(write-string ,(format nil "" string-code) - *html-stream*))) + (:set (if has-inv + `(write-string ,(format nil "<~a>" string-code) + *html-stream*) + `(write-string ,(format nil "<~a />" string-code) + *html-stream*))) + (:unset (when has-inv + `(write-string ,(format nil "" string-code) + *html-stream*))) (t (error "illegal arg ~s to ~s" args string-code))))) (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*))))) @@ -238,19 +272,18 @@ ;; 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) @@ -260,12 +293,8 @@ (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 )) @@ -277,17 +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 - (if* (< start i) - then (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)))))) @@ -325,10 +351,10 @@ 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 @@ -358,7 +384,7 @@ then (funcall print-handler ent :full - (if* (consp (car form)) then (cdr (car form))) + (when (consp (car form)) (cdr (car form))) form subst unknown @@ -379,8 +405,8 @@ ((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)) @@ -389,9 +415,9 @@ (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 @@ -425,9 +451,9 @@ 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 "" (html-process-key ent)))))) + (when (html-process-has-inverse ent) + ;; end the form + (format stream "" (html-process-key ent)))))) @@ -485,17 +511,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 @@ -509,9 +534,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 @@ -524,9 +549,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 @@ -539,9 +564,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 @@ -554,9 +579,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 @@ -726,7 +751,7 @@ ;; must use syntax (declare (ignore ent args argsp)) `(progn - (write-string "