X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=htmlgen.lisp;h=387ba8bfd73ee60c5316a1866895a4e080e77f33;hp=62a99e9733de03c80236c3b8c6d2d3f010f2b5e4;hb=baab0724ae6b89da695994a9ca394b47a0559dc4;hpb=38e4f57a38547532d06019a60969937d251a554b diff --git a/htmlgen.lisp b/htmlgen.lisp index 62a99e9..387ba8b 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -1,6 +1,6 @@ ;; -*- mode: common-lisp; package: lml2 -*- ;; -;; $Id: htmlgen.lisp,v 1.9 2003/06/24 20:20:12 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 @@ -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 @@ -153,14 +150,14 @@ ;; 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)) @@ -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 @@ -763,7 +750,7 @@ (unless body (error "must have a body with :insert-file")) `(progn ,@(mapcar #'(lambda (bod) - `(lml-load-path ,bod)) + `(lml-load ,bod)) body)))) (named-function html-nbsp-print-function @@ -771,7 +758,7 @@ (declare (ignore ent unknown subst stream args)) (assert (eql 2 (length form))) (if (eq cmd :full) - (lml-load-path (cadr form)) + (lml-load (cadr form)) (error ":insert-file must be given an argument")))))