X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=387ba8bfd73ee60c5316a1866895a4e080e77f33;hp=3149977974f92978fcb5e8cfc340e7664afef3be;hb=baab0724ae6b89da695994a9ca394b47a0559dc4;hpb=cf3975484f2a142ab18c503e1c39fdabd140582d diff --git a/htmlgen.lisp b/htmlgen.lisp index 3149977..387ba8b 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.7 2003/06/24 17:51:22 kevin Exp $ +;; $Id: htmlgen.lisp,v 1.11 2003/06/29 16:21:09 kevin Exp $ ;; ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA ;; copyright (c) 2003 Kevin Rosenberg @@ -9,6 +9,7 @@ ;; - Support XHTML end tags ;; - lowercase symbol names for attributes ;; - Add custom tags such as :jscript, :insert-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 @@ -45,11 +46,11 @@ (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) @@ -99,10 +100,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 +112,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 @@ -149,22 +146,22 @@ (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 @@ -194,18 +191,18 @@ ,(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*))) + ,(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 - ,(if* body - then `(write-string ,(format nil "" string-code) - *html-stream*))) + ,(when body + `(write-string ,(format nil "" string-code) + *html-stream*))) else `(progn (write-string ,(format nil "<~a />" string-code) *html-stream*))))) @@ -238,19 +235,17 @@ ;; 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))))) + then (write-char #\" *html-stream*) + (emit-safe *html-stream* val) + (write-char #\" *html-stream*) + else (prin1-safe-http val)))) (defun emit-safe (stream string) @@ -260,12 +255,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 )) @@ -280,11 +271,8 @@ (if* cvt then ; must do a conversion, emit previous chars first - (if* (< start i) - then (write-sequence string - stream - :start start - :end i)) + (when (< start i) + (write-sequence string stream :start start :end i)) (write-string cvt stream) (setq start (1+ i)))))) @@ -325,10 +313,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 +346,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 +367,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 +377,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 +413,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 +473,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 +496,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 +511,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 +526,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 +541,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 @@ -752,9 +739,9 @@ (named-function html-nbsp-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore args ent unknown subst)) - (if* (eq cmd :set) - then (write-string " " stream) - else (error ":nbsp in an illegal place: ~s" form))))) + (if (eq cmd :set) + (write-string " " stream) + (error ":nbsp in an illegal place: ~s" form))))) (def-special-html :insert-file (named-function html-nbsp-function @@ -762,11 +749,47 @@ (declare (ignore ent args argsp)) (unless body (error "must have a body with :insert-file")) - `(lml-load-path (car ',body)))) + `(progn ,@(mapcar #'(lambda (bod) + `(lml-load ,bod)) + body)))) (named-function html-nbsp-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore ent unknown subst stream args)) - (if* (eq cmd :full) - then (lml-load-path (cadr form)) - else (error ":insert-file must be given an argument"))))) + (assert (eql 2 (length form))) + (if (eq cmd :full) + (lml-load (cadr form)) + (error ":insert-file must be given an argument"))))) + + +(def-special-html :write-string + (named-function html-write-string-function + (lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(write-string ,bod *html-stream*)) + body)))) + + (named-function html-write-string-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) + (write-string (cadr form) stream) + (error ":write-string must be given an argument"))))) + +(def-special-html :write-char + (named-function html-write-char-function + (lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(write-char ,bod *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) + (write-char (cadr form) stream) + (error ":write-char must be given an argument")))))