From 9c5e52ab7792dc7e57d02141c797d95b31b23039 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 31 Aug 2007 18:04:31 +0000 Subject: [PATCH 1/1] r11859: Canonicalize whitespace --- apache-dir.lisp | 250 ++++++------- base.lisp | 40 +- downloads.lisp | 134 +++---- files.lisp | 34 +- htmlgen.lisp | 976 ++++++++++++++++++++++++------------------------ package.lisp | 6 +- read-macro.lisp | 108 +++--- stdsite.lisp | 34 +- utils.lisp | 2 +- 9 files changed, 792 insertions(+), 792 deletions(-) diff --git a/apache-dir.lisp b/apache-dir.lisp index 0730653..9cd155a 100644 --- a/apache-dir.lisp +++ b/apache-dir.lisp @@ -33,58 +33,58 @@ (defun universal-time-to-apache-date (utime) (multiple-value-bind - (second minute hour day-of-month month year day-of-week daylight-p zone) + (second minute hour day-of-month month year day-of-week daylight-p zone) (decode-universal-time utime) (declare (ignore second day-of-week daylight-p zone)) (format nil - (formatter "~2,'0D-~3/kmrcl::monthname/-~4,'0D ~2,'0D:~2,'0D") - day-of-month month year hour minute))) - + (formatter "~2,'0D-~3/kmrcl::monthname/-~4,'0D ~2,'0D:~2,'0D") + day-of-month month year hour minute))) + (defun sort-dir-entries (entries sort-field direct) (case sort-field (:name (sort entries - (lambda (a b) - (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp) - (aif (third a) it "") - (aif (third b) it ""))))) + (lambda (a b) + (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp) + (aif (third a) it "") + (aif (third b) it ""))))) (:modified (sort entries - (lambda (a b) - (funcall (if (eq direct :asc) #'< #'>) - (aif (fourth a) it 0) - (aif (fourth b) it 0))))) + (lambda (a b) + (funcall (if (eq direct :asc) #'< #'>) + (aif (fourth a) it 0) + (aif (fourth b) it 0))))) (:size (sort entries - (lambda (a b) - (funcall (if (eq direct :asc) #'< #'>) - (aif (fifth a) it 0) - (aif (fifth b) it 0))))) + (lambda (a b) + (funcall (if (eq direct :asc) #'< #'>) + (aif (fifth a) it 0) + (aif (fifth b) it 0))))) (:description (sort entries - (lambda (a b) - (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp) - (aif (sixth a) it "") - (aif (sixth b) it ""))))) + (lambda (a b) + (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp) + (aif (sixth a) it "") + (aif (sixth b) it ""))))) (t entries))) - + (defun write-html-apache-directory (stream title entries this-url &key parent address query-string - icon-base) + icon-base) (let* ((query (when query-string (split-uri-query-string query-string))) - (sort-field (if query - (cond - ((string-equal (caar query) "N") :name) - ((string-equal (caar query) "M") :modified) - ((string-equal (caar query) "S") :size) - ((string-equal (caar query) "D") :description) - (t :name)) - :name)) - (dir (cond - ((and query (string-equal (cdr (first query)) "D") :desc)) - (t :asc)))) + (sort-field (if query + (cond + ((string-equal (caar query) "N") :name) + ((string-equal (caar query) "M") :modified) + ((string-equal (caar query) "S") :size) + ((string-equal (caar query) "D") :description) + (t :name)) + :name)) + (dir (cond + ((and query (string-equal (cdr (first query)) "D") :desc)) + (t :asc)))) (setq entries (sort-dir-entries entries sort-field dir)) - + (html-stream stream "" @@ -98,100 +98,100 @@ ((:body :bgcolor "#FFFFFF" :text "#000000") :newline (:table - (:tr - ((:td :bgcolor "#FFFFFF" :class "title") - ((:font :size "+3" :face "Hevetica,Arial,sans-serif") - (:b (:princ title)))))) + (:tr + ((:td :bgcolor "#FFFFFF" :class "title") + ((:font :size "+3" :face "Hevetica,Arial,sans-serif") + (:b (:princ title)))))) :newline (:pre - (when icon-base - (html-stream - stream - ((:img :border "0" - :src (format nil "~Ablank.png" icon-base) - :alt " ")))) - " " - ((:a :href (format nil "~A?N=~A" this-url - (if (and (eq sort-field :name) (eq dir :asc)) - "D" "A"))) - "Name") - (:princ (format nil "~20A" "")) - " " - ((:a :href (format nil "~A?M=~A" this-url - (if (and (eq sort-field :modified) (eq dir :asc)) - "D" "A"))) - "Last modified") - " " - ((:a :href (format nil "~A?S=~A" this-url - (if (and (eq sort-field :size) (eq dir :asc)) - "D" "A"))) - "Size") - " " - ((:a :href (format nil "~A?D=~A" this-url - (if (and (eq sort-field :description) (eq dir :asc)) - "D" "A"))) - "Description") - :newline - (:princ "
") - :newline - (when parent - (html-stream - stream - (when icon-base - (html-stream - stream - ((:img :border "0" - :src (format nil "~Aback.png" icon-base) - :alt "[DIR]")))) - " " - (write-name-link stream (first parent) (second parent)) - " " - (print-n-chars #\space 17 stream) - " -" - :newline)) - (dolist (entry entries) - (html-stream - stream - (when icon-base - (html-stream - stream - ((:img :border "0" - :src - (case (car entry) - (:dir (format nil "~Afolder.png" icon-base)) - (:text (format nil "~Atext.png" icon-base)) - (t (format nil "~Af.png" icon-base))) - :alt - (case (car entry) - (:dir "[DIR]") - (:text "[TXT]") - (t "[FIL]")))))) - " " - (write-name-link stream (second entry) (third entry)) - " " - (:princ (universal-time-to-apache-date (fourth entry))) - (:princ - (cond - ((or (eq :dir (first entry)) - (null (fifth entry))) - " -") - ((< (fifth entry) (* 1024 1024)) - (format nil "~5,' Dk" (round (fifth entry) 1024))) - ((< (fifth entry) (* 1024 1024 1024)) - (format nil "~5,' Dm" (round (fifth entry) (* 1024 1024)))) - (t - (format nil "~5,' Dg" (round (fifth entry) (* 1024 1024 1024)))) - )) - " " - (:princ - (if (sixth entry) - (sixth entry) - "")) - :newline))) + (when icon-base + (html-stream + stream + ((:img :border "0" + :src (format nil "~Ablank.png" icon-base) + :alt " ")))) + " " + ((:a :href (format nil "~A?N=~A" this-url + (if (and (eq sort-field :name) (eq dir :asc)) + "D" "A"))) + "Name") + (:princ (format nil "~20A" "")) + " " + ((:a :href (format nil "~A?M=~A" this-url + (if (and (eq sort-field :modified) (eq dir :asc)) + "D" "A"))) + "Last modified") + " " + ((:a :href (format nil "~A?S=~A" this-url + (if (and (eq sort-field :size) (eq dir :asc)) + "D" "A"))) + "Size") + " " + ((:a :href (format nil "~A?D=~A" this-url + (if (and (eq sort-field :description) (eq dir :asc)) + "D" "A"))) + "Description") + :newline + (:princ "
") + :newline + (when parent + (html-stream + stream + (when icon-base + (html-stream + stream + ((:img :border "0" + :src (format nil "~Aback.png" icon-base) + :alt "[DIR]")))) + " " + (write-name-link stream (first parent) (second parent)) + " " + (print-n-chars #\space 17 stream) + " -" + :newline)) + (dolist (entry entries) + (html-stream + stream + (when icon-base + (html-stream + stream + ((:img :border "0" + :src + (case (car entry) + (:dir (format nil "~Afolder.png" icon-base)) + (:text (format nil "~Atext.png" icon-base)) + (t (format nil "~Af.png" icon-base))) + :alt + (case (car entry) + (:dir "[DIR]") + (:text "[TXT]") + (t "[FIL]")))))) + " " + (write-name-link stream (second entry) (third entry)) + " " + (:princ (universal-time-to-apache-date (fourth entry))) + (:princ + (cond + ((or (eq :dir (first entry)) + (null (fifth entry))) + " -") + ((< (fifth entry) (* 1024 1024)) + (format nil "~5,' Dk" (round (fifth entry) 1024))) + ((< (fifth entry) (* 1024 1024 1024)) + (format nil "~5,' Dm" (round (fifth entry) (* 1024 1024)))) + (t + (format nil "~5,' Dg" (round (fifth entry) (* 1024 1024 1024)))) + )) + " " + (:princ + (if (sixth entry) + (sixth entry) + "")) + :newline))) (:princ "
") :newline (when address - (html-stream - stream - (:address address)))))))) + (html-stream + stream + (:address address)))))))) diff --git a/base.lisp b/base.lisp index 7054761..208e1a7 100644 --- a/base.lisp +++ b/base.lisp @@ -20,8 +20,8 @@ (defun lml-format (str &rest args) (when (streamp *html-stream*) (if args - (apply #'format *html-stream* str args) - (write-string str *html-stream*)))) + (apply #'format *html-stream* str args) + (write-string str *html-stream*)))) (defun lml-princ (s) (princ s *html-stream*)) @@ -39,16 +39,16 @@ (lml-write-string (date-string date))) (defun xml-header-stream (stream &key (version "1.0") (standalone :unspecified) - (encoding :unspecified)) + (encoding :unspecified)) (format stream "" - version - (if (eq standalone :unspecified) - "" - (format nil " standalone=\"~A\"" standalone)) - (if (eq encoding :unspecified) - "" - (format nil " encoding=\"~A\"" encoding)))) - + version + (if (eq standalone :unspecified) + "" + (format nil " standalone=\"~A\"" standalone)) + (if (eq encoding :unspecified) + "" + (format nil " encoding=\"~A\"" encoding)))) + (defun dtd-prologue (&optional (format :xhtml11) &key entities) (case format ((:xhtml :xhtml11 :xhtml10-strict :xhtml10-transitional :xhtml10-frameset :xml) @@ -56,13 +56,13 @@ (lml-write-char #\newline) (case format ((:xhtml11 :xhtml) - (lml-write-string +xhtml11-dtd-string+)) + (lml-write-string +xhtml11-dtd-string+)) (:xhtml10-strict - (lml-write-string +xhtml10-strict-dtd-string+)) + (lml-write-string +xhtml10-strict-dtd-string+)) (:xhtml10-transitional - (lml-write-string +xhtml10-transitional-dtd-string+)) + (lml-write-string +xhtml10-transitional-dtd-string+)) (:xhtml10-frameset - (lml-write-string +xhtml10-frameset-dtd-string+))) + (lml-write-string +xhtml10-frameset-dtd-string+))) (when entities (lml-write-char #\space) (lml-write-char #\[) @@ -77,16 +77,16 @@ (defmacro html-file-page ((out-file &key (format :xhtml11)) - &body body) + &body body) `(with-open-file (*html-stream* - (lml-file-name ',out-file :output) - :direction :output - :if-exists :supersede) + (lml-file-name ',out-file :output) + :direction :output + :if-exists :supersede) (dtd-prologue ,format) (html ((:html :xmlns "http://www.w3.org/1999/xhtml") ,@body)))) - + (defmacro alink (url desc) `(html diff --git a/downloads.lisp b/downloads.lisp index 855505b..21473d1 100644 --- a/downloads.lisp +++ b/downloads.lisp @@ -26,34 +26,34 @@ (defun strip-dl-base (file base) (let ((fdir (pathname-directory file)) - (bdir (pathname-directory base))) + (bdir (pathname-directory base))) (make-pathname :name (pathname-name file) :type (pathname-type file) - :directory + :directory (when (> (length fdir) (length bdir)) - (append '(:absolute) - (subseq fdir (length bdir) (length fdir))))))) - + (append '(:absolute) + (subseq fdir (length bdir) (length fdir))))))) + (defun print-file (file dl-data) (let ((size 0) - (modtime (date-string (file-write-date file))) - (basename (namestring - (make-pathname :name (pathname-name file) - :type (pathname-type file)))) - (dl-name (strip-dl-base file (dl-data-base dl-data))) - (sig-path (concatenate 'string (namestring file) ".asc"))) + (modtime (date-string (file-write-date file))) + (basename (namestring + (make-pathname :name (pathname-name file) + :type (pathname-type file)))) + (dl-name (strip-dl-base file (dl-data-base dl-data))) + (sig-path (concatenate 'string (namestring file) ".asc"))) (when (plusp (length basename)) (with-open-file (strm file :direction :input) - (setq size (round (/ (file-length strm) 1024)))) + (setq size (round (/ (file-length strm) 1024)))) (lml-format "~A" - (dl-data-url dl-data) dl-name basename) + (dl-data-url dl-data) dl-name basename) (lml-princ "") (lml-format " (~A, ~:D KB)" modtime size) (when (probe-file sig-path) - (setf (dl-data-signed dl-data) t) - (lml-format " [Signature]" - (dl-data-url dl-data) dl-name)) + (setf (dl-data-signed dl-data) t) + (lml-format " [Signature]" + (dl-data-url dl-data) dl-name)) (html :br)))) (defun display-header (name url) @@ -68,10 +68,10 @@ (lml-princ "

GPG Public Key

") (lml-princ "Use this key to verify file signtatures")) (lml-princ "")) - + (defun print-sect-title (title dl-data) (lml-format "~A" - (dl-data-indent dl-data) title (dl-data-indent dl-data))) + (dl-data-indent dl-data) title (dl-data-indent dl-data))) (defun match-base-name? (name base-name) (let ((len-base-name (length base-name))) @@ -80,7 +80,7 @@ (defun match-base-name-latest? (name base-name) (let* ((latest (concatenate 'string base-name "-latest")) - (len-latest (length latest))) + (len-latest (length latest))) (when (>= (length name) len-latest) (string= name latest :end1 len-latest :end2 len-latest)))) @@ -99,9 +99,9 @@ (defun display-one-section (title pat dl-data) (let ((files (sort-pathnames - (filter-latest - (filter-against-base (directory pat) (dl-data-name dl-data)) - (dl-data-name dl-data))))) + (filter-latest + (filter-against-base (directory pat) (dl-data-name dl-data)) + (dl-data-name dl-data))))) (when files (print-sect-title title dl-data) (lml-princ "
") @@ -111,24 +111,24 @@ (defun display-sections (sects dl-data) (when sects (let ((title (car sects)) - (value (cadr sects))) + (value (cadr sects))) (if (consp title) - (dolist (sect sects) - (display-sections sect dl-data)) - (if (consp value) - (progn - (print-sect-title title dl-data) - (incf (dl-data-indent dl-data)) - (display-sections value dl-data) - (decf (dl-data-indent dl-data))) - (display-one-section title value dl-data)))))) - + (dolist (sect sects) + (display-sections sect dl-data)) + (if (consp value) + (progn + (print-sect-title title dl-data) + (incf (dl-data-indent dl-data)) + (display-sections value dl-data) + (decf (dl-data-indent dl-data))) + (display-one-section title value dl-data)))))) + (defun display-page (pkg-name pkg-base dl-base dl-url sects) (let ((dl-data (make-dl-data :indent 3 - :base dl-base - :url dl-url - :name pkg-base - :signed nil))) + :base dl-base + :url dl-url + :name pkg-base + :signed nil))) (display-header pkg-name dl-url) (dolist (sect sects) (display-sections sect dl-data)) @@ -137,38 +137,38 @@ (defun std-dl-page (pkg-name pkg-base dl-base dl-url) (let ((base (parse-namestring dl-base))) (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild)) - (zip-path (make-pathname :defaults base :type "zip" :name :wild)) - (doc-path (make-pathname :defaults base :type "pdf" :name :wild))) + (zip-path (make-pathname :defaults base :type "zip" :name :wild)) + (doc-path (make-pathname :defaults base :type "pdf" :name :wild))) (display-page pkg-name pkg-base dl-base dl-url - `(("Manual" ,doc-path) - ("Source Code" - (("Unix (.tar.gz)" ,tgz-path) - ("Windows (.zip)" ,zip-path)))))))) - + `(("Manual" ,doc-path) + ("Source Code" + (("Unix (.tar.gz)" ,tgz-path) + ("Windows (.zip)" ,zip-path)))))))) + (defun full-dl-page (pkg-name pkg-base dl-base dl-url) (let ((base (parse-namestring dl-base))) (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild)) - (zip-path (make-pathname :defaults base :type "zip" :name :wild)) - (doc-path (make-pathname :defaults base :type "pdf" :name :wild)) - (deb-path (merge-pathnames - (make-pathname :directory '(:relative "linux-debian") - :type :wild :name :wild) - base)) - (rpm-path (merge-pathnames - (make-pathname :directory '(:relative "linux-rpm") - :type :wild :name :wild) - base)) - (w32-path (merge-pathnames - (make-pathname :directory '(:relative "win32") - :type :wild :name :wild) - base))) + (zip-path (make-pathname :defaults base :type "zip" :name :wild)) + (doc-path (make-pathname :defaults base :type "pdf" :name :wild)) + (deb-path (merge-pathnames + (make-pathname :directory '(:relative "linux-debian") + :type :wild :name :wild) + base)) + (rpm-path (merge-pathnames + (make-pathname :directory '(:relative "linux-rpm") + :type :wild :name :wild) + base)) + (w32-path (merge-pathnames + (make-pathname :directory '(:relative "win32") + :type :wild :name :wild) + base))) (display-page pkg-name pkg-base dl-base dl-url - `(("Manual" ,doc-path) - ("Source Code" - (("Unix (.tar.gz)" ,tgz-path) - ("Windows (.zip)" ,zip-path))) - ("Binaries" - (("Linux Binaries" - (("Debian Linux" ,deb-path) - ("RedHat Linux" ,rpm-path))) - ("Windows Binaries" ,w32-path)))))))) + `(("Manual" ,doc-path) + ("Source Code" + (("Unix (.tar.gz)" ,tgz-path) + ("Windows (.zip)" ,zip-path))) + ("Binaries" + (("Linux Binaries" + (("Debian Linux" ,deb-path) + ("RedHat Linux" ,rpm-path))) + ("Windows Binaries" ,w32-path)))))))) diff --git a/files.lisp b/files.lisp index 9c5dd2e..068347c 100644 --- a/files.lisp +++ b/files.lisp @@ -28,23 +28,23 @@ (unless (position #\. f) (setq f (concatenate 'string f ".html")))) (if (or (and (eq type :source) *sources-dir*) - (and (eq type :output) *output-dir*)) + (and (eq type :output) *output-dir*)) (merge-pathnames (make-pathname :name (pathname-name f) - :type (pathname-type f) - :directory (pathname-directory f)) + :type (pathname-type f) + :directory (pathname-directory f)) (ecase type - (:source *sources-dir*) - (:output *output-dir*))) + (:source *sources-dir*) + (:output *output-dir*))) (if (stringp f) - (parse-namestring f) - f))) + (parse-namestring f) + f))) (defmacro with-dir ((output &key sources) &body body) (let ((output-dir (gensym)) - (sources-dir (gensym))) + (sources-dir (gensym))) `(let ((,output-dir ,output) - (,sources-dir ,sources)) + (,sources-dir ,sources)) (when (stringp ,output-dir) (setq ,output-dir (parse-namestring ,output-dir))) (when (stringp ,sources-dir) @@ -52,27 +52,27 @@ (unless ,sources-dir (setq ,sources-dir ,output-dir)) (let ((*output-dir* ,output-dir) - (*sources-dir* ,sources-dir)) + (*sources-dir* ,sources-dir)) ,@body)))) (defun lml-load-path (file &key optional) (if (probe-file file) (with-open-file (in file :direction :input) (do ((form (read in nil 'eof) (read in nil 'eof))) - ((eq form 'eof)) - (eval form))) + ((eq form 'eof)) + (eval form))) (unless optional (format *trace-output* "Warning: unable to load LML file ~S" file)))) (defun process-dir (dir &key sources) (with-dir (dir :sources sources) (let ((lml-files (directory - (make-pathname :defaults *sources-dir* - :name :wild - :type "lml")))) + (make-pathname :defaults *sources-dir* + :name :wild + :type "lml")))) (dolist (file lml-files) - (format *trace-output* "~&; Processing ~A~%" file) - (lml-load-path file))))) + (format *trace-output* "~&; Processing ~A~%" file) + (lml-load-path file))))) (defun lml-load (file &key optional) (lml-load-path (eval `(lml-file-name ,file :source)) :optional optional)) diff --git a/htmlgen.lisp b/htmlgen.lisp index 97287b2..4fa517e 100644 --- a/htmlgen.lisp +++ b/htmlgen.lisp @@ -2,7 +2,7 @@ ;; ;; $Id$ ;; -;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA ;; copyright (c) 2003 Kevin Rosenberg ;; ;; Main changes from Allegro version: @@ -10,13 +10,13 @@ ;; - lowercase symbol names for attributes ;; - Add custom tags such as :jscript, :insert-file, :load-file, :nbsp ;; - removal of if* macro -;; - Add attribute conditions +;; - Add attribute conditions ;; - Automatic conversion to strings for attribute values ;; - Convert some comments to function doc strings ;; ;; This code is free software; you can redistribute it and/or ;; modify it under the terms of the version 2.1 of -;; the GNU Lesser General Public License as published by +;; the GNU Lesser General Public License as published by ;; the Free Software Foundation, as clarified by the LLGPL @@ -24,14 +24,14 @@ (defstruct (html-process (:type list) (:constructor - make-html-process (key has-inverse - macro special - print - name-attr - ))) - key ; keyword naming this tag - has-inverse ; t if the / form is used - macro ; the macro to define this + make-html-process (key has-inverse + macro special + print + name-attr + ))) + key ; keyword naming this tag + has-inverse ; t if the / form is used + macro ; the macro to define this special ; if true then call this to process the keyword and return ; the macroexpansion print ; function used to handle this in html-print @@ -39,7 +39,7 @@ ) -(defparameter *html-process-table* +(defparameter *html-process-table* (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes ) @@ -51,35 +51,35 @@ "KMR: Walk through forms and combine write-strings" (let (res strs last-stream) (flet ((flush-strings () - (when strs - (push `(write-string ,strs ,last-stream) res) - (setq strs nil) - (setq last-stream nil)))) + (when strs + (push `(write-string ,strs ,last-stream) res) + (setq strs nil) + (setq last-stream nil)))) (do* ((forms input-forms (cdr forms)) - (form (car forms) (car forms))) - ((null forms) - (flush-strings) - (nreverse res)) - (cond - ((atom form) - (flush-strings) - (push form res)) - ((and (eq (car form) 'cl:write-string) - (stringp (cadr form))) - (if strs - (if (eq last-stream (third form)) - (setq strs (concatenate 'string strs (second form))) - (progn - (flush-strings) - (setq strs (second form)) - (setq last-stream (third form)))) - (progn - (setq strs (second form)) - (setq last-stream (third form))))) - (t - (flush-strings) - (push (post-process-html-forms form) res))))))) - + (form (car forms) (car forms))) + ((null forms) + (flush-strings) + (nreverse res)) + (cond + ((atom form) + (flush-strings) + (push form res)) + ((and (eq (car form) 'cl:write-string) + (stringp (cadr form))) + (if strs + (if (eq last-stream (third form)) + (setq strs (concatenate 'string strs (second form))) + (progn + (flush-strings) + (setq strs (second form)) + (setq last-stream (third form)))) + (progn + (setq strs (second form)) + (setq last-stream (third form))))) + (t + (flush-strings) + (push (post-process-html-forms form) res))))))) + (defmacro html-out-stream-check (stream) ;; ensure that a real stream is passed to this function @@ -98,93 +98,93 @@ (defun process-html-forms (forms env) (let (res) (flet ((do-ent (ent args argsp body) - ;; ent is an html-process object associated with the - ;; html tag we're processing - ;; args is the list of values after the tag in the form - ;; ((:tag &rest args) ....) - ;; 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) - (cond - ((setq spec (html-process-special ent)) - ;; do something different - (push (funcall spec ent args argsp body) res)) - ((null argsp) - ;; singleton tag, just do the set - (push `(,(html-process-macro ent) :set) res) - nil) - (t - (cond ((equal args '(:unset)) - ;; ((:tag :unset)) is a special case. - ;; that allows us to close off singleton tags - ;; printed earlier. - (push `(,(html-process-macro ent) :unset) res) - nil) - (t - ;; some args - (push `(,(html-process-macro ent) - ,args - ,(process-html-forms body env)) - res) - nil))))))) - + ;; ent is an html-process object associated with the + ;; html tag we're processing + ;; args is the list of values after the tag in the form + ;; ((:tag &rest args) ....) + ;; 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) + (cond + ((setq spec (html-process-special ent)) + ;; do something different + (push (funcall spec ent args argsp body) res)) + ((null argsp) + ;; singleton tag, just do the set + (push `(,(html-process-macro ent) :set) res) + nil) + (t + (cond ((equal args '(:unset)) + ;; ((:tag :unset)) is a special case. + ;; that allows us to close off singleton tags + ;; printed earlier. + (push `(,(html-process-macro ent) :unset) res) + nil) + (t + ;; some args + (push `(,(html-process-macro ent) + ,args + ,(process-html-forms body env)) + res) + nil))))))) + (do* ((xforms forms (cdr xforms)) - (form (car xforms) (car xforms))) - ((null xforms)) - - (setq form (macroexpand form env)) - - (if (atom form) - (cond - ((keywordp form) - (let ((ent (gethash form *html-process-table*))) - (if (null ent) - (error "unknown html keyword ~s" form) - (do-ent ent nil nil nil)))) - ((stringp form) - ;; turn into a print of it - (push `(write-string ,form *html-stream*) res)) - (t - (push form res))) - (let ((first (car form))) - (cond - ((keywordp first) - ;; (:xxx . body) form - (let ((ent (gethash first - *html-process-table*))) - (if (null ent) - (error "unknown html keyword ~s" form) - (do-ent ent nil t (cdr form))))) - ((and (consp first) (keywordp (car first))) - ;; ((:xxx args ) . body) - (let ((ent (gethash (car first) - *html-process-table*))) - (if (null ent) - (error "unknown html keyword ~s" form) - (do-ent ent (cdr first) t (cdr form))))) - (t - (push form res))))))) + (form (car xforms) (car xforms))) + ((null xforms)) + + (setq form (macroexpand form env)) + + (if (atom form) + (cond + ((keywordp form) + (let ((ent (gethash form *html-process-table*))) + (if (null ent) + (error "unknown html keyword ~s" form) + (do-ent ent nil nil nil)))) + ((stringp form) + ;; turn into a print of it + (push `(write-string ,form *html-stream*) res)) + (t + (push form res))) + (let ((first (car form))) + (cond + ((keywordp first) + ;; (:xxx . body) form + (let ((ent (gethash first + *html-process-table*))) + (if (null ent) + (error "unknown html keyword ~s" form) + (do-ent ent nil t (cdr form))))) + ((and (consp first) (keywordp (car first))) + ;; ((:xxx args ) . body) + (let ((ent (gethash (car first) + *html-process-table*))) + (if (null ent) + (error "unknown html keyword ~s" form) + (do-ent ent (cdr first) t (cdr form))))) + (t + (push form res))))))) `(progn ,@(nreverse res)))) (defun html-atom-check (args open close body) (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))))) + (: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)))) + (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 `(progn (write-string ,open *html-stream*) - ,@body - (write-string ,close *html-stream*))) + ,@body + (write-string ,close *html-stream*))) (defun attribute-name-string (name) @@ -194,113 +194,113 @@ (defun process-attributes (args) (flet ((write-attribute-name-forms (name) - `((write-char #\space *html-stream*) - (write-string ,(attribute-name-string name) - *html-stream*))) - (write-separator-forms () - '((write-char #\= *html-stream*) - (write-char #\" *html-stream*)))) + `((write-char #\space *html-stream*) + (write-string ,(attribute-name-string name) + *html-stream*))) + (write-separator-forms () + '((write-char #\= *html-stream*) + (write-char #\" *html-stream*)))) (do* ((xx args (cddr xx)) - (res) - (name (first xx) (first xx)) - (value (second xx) (second xx))) - ((null xx) - (nreverse res)) + (res) + (name (first xx) (first xx)) + (value (second xx) (second xx))) + ((null xx) + (nreverse res)) (case name - (:fformat - (unless (and (listp value) - (>= (length value) 2)) - (error ":fformat must be given a list at least 2 elements")) - (mapcar (lambda (f) (push f res)) - (write-attribute-name-forms (first value))) - (mapcar (lambda (f) (push f res)) - (write-separator-forms)) - (push `(fformat *html-stream* ,(second value) ,@(cddr value)) - res) - (push `(write-char #\" *html-stream*) res)) + (:fformat + (unless (and (listp value) + (>= (length value) 2)) + (error ":fformat must be given a list at least 2 elements")) + (mapcar (lambda (f) (push f res)) + (write-attribute-name-forms (first value))) + (mapcar (lambda (f) (push f res)) + (write-separator-forms)) + (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")) + (error ":format must be given a list at least 2 elements")) (mapcar (lambda (f) (push f res)) - (write-attribute-name-forms (first value))) + (write-attribute-name-forms (first value))) (push `(prin1-safe-http-string - (format nil ,(second value) ,@(cddr value))) - res)) + (format nil ,(second value) ,@(cddr value))) + res)) (:optional (let ((eval-if (gensym "EVAL-IF-"))) - (push `(let ((,eval-if ,(second value))) - (when ,eval-if - ,@(write-attribute-name-forms (first value)) - (prin1-safe-http-string ,eval-if))) - res))) + (push `(let ((,eval-if ,(second value))) + (when ,eval-if + ,@(write-attribute-name-forms (first value)) + (prin1-safe-http-string ,eval-if))) + 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-attribute-name-forms (first value)) - (prin1-safe-http-string - (if ,eval-if - ,(third value) - ,(fourth value)))) - res))) + (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-attribute-name-forms (first value)) + (prin1-safe-http-string + (if ,eval-if + ,(third value) + ,(fourth value)))) + res))) (:when - (unless (and (listp value) - (= (length value) 3)) - (error ":when must be given a list with 3 elements")) - (push `(when ,(second value) - ,@(write-attribute-name-forms (first value)) - (prin1-safe-http-string ,(third value))) - res)) + (unless (and (listp value) + (= (length value) 3)) + (error ":when must be given a list with 3 elements")) + (push `(when ,(second value) + ,@(write-attribute-name-forms (first value)) + (prin1-safe-http-string ,(third value))) + res)) (t (mapcar (lambda (f) (push f res)) - (write-attribute-name-forms name)) + (write-attribute-name-forms name)) (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 (when (and args (atom args)) - ;; single arg + ;; 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 (when has-inv - `(write-string ,(format nil "" string-code) - *html-stream*))) - (t (error "illegal arg ~s to ~s" args string-code))))) - + (: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 `(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*))) + *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*) + ,@body + ,(when body + `(write-string ,(format nil "" string-code) + *html-stream*))) `(progn (write-string ,(format nil "<~a />" string-code) - *html-stream*))))) + *html-stream*))))) @@ -332,21 +332,21 @@ ;; symbols are turned into their name ;; ;; non-string and non-symbols are written to a string and quoted - + (unless (and (symbolp val) - (equal "" (symbol-name val))) + (equal "" (symbol-name val))) (write-char #\= *html-stream*) (when (not (or (stringp val) - (symbolp val))) + (symbolp val))) (setq val (write-to-string 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*)) + (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)))) @@ -354,26 +354,26 @@ "Send the string to the http response stream watching out for special html characters and encoding them appropriately." (do* ((i 0 (1+ i)) - (start i) - (end (length string))) + (start i) + (end (length string))) ((>= i end) (when (< start i) - (write-sequence string stream :start start :end i))) - + (write-sequence string stream :start start :end i))) + (let* ((ch (schar string i)) - (cvt (case ch - (#\< "<") - (#\> ">") - (#\& "&") - (#\" """)))) + (cvt (case ch + (#\< "<") + (#\> ">") + (#\& "&") + (#\" """)))) (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)))))) - - + ;; 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)))))) + + (defun html-print-list (list-of-forms stream &key unknown) ;; html print a list of forms @@ -394,91 +394,91 @@ (defun html-print-subst (form subst stream unknown) ;; Print the given lhtml form to the given stream (assert (streamp stream)) - - + + (let* ((attrs) - (attr-name) - (name) - (possible-kwd (cond - ((atom form) form) - ((consp (car form)) - (setq attrs (cdar form)) - (caar form)) - (t (car form)))) - print-handler - ent) + (attr-name) + (name) + (possible-kwd (cond + ((atom form) form) + ((consp (car form)) + (setq attrs (cdar form)) + (caar form)) + (t (car form)))) + print-handler + ent) (when (keywordp possible-kwd) (if (null (setq ent (gethash possible-kwd *html-process-table*))) - (if unknown - (return-from html-print-subst - (funcall unknown form stream)) - (error "unknown html tag: ~s" possible-kwd)) - ;; see if we should subst - (when (and subst - attrs - (setq attr-name (html-process-name-attr ent)) - (setq name (getf attrs attr-name)) - (setq attrs (html-find-value name subst))) - (return-from html-print-subst - (if (functionp (cdr attrs)) - (funcall (cdr attrs) stream) - (html-print-subst - (cdr attrs) - subst - stream - unknown))))) - + (if unknown + (return-from html-print-subst + (funcall unknown form stream)) + (error "unknown html tag: ~s" possible-kwd)) + ;; see if we should subst + (when (and subst + attrs + (setq attr-name (html-process-name-attr ent)) + (setq name (getf attrs attr-name)) + (setq attrs (html-find-value name subst))) + (return-from html-print-subst + (if (functionp (cdr attrs)) + (funcall (cdr attrs) stream) + (html-print-subst + (cdr attrs) + subst + stream + unknown))))) + (setq print-handler - (html-process-print ent))) - + (html-process-print ent))) + (cond ((atom form) (cond ((keywordp form) - (funcall print-handler ent :set nil nil nil nil stream)) + (funcall print-handler ent :set nil nil nil nil stream)) ((stringp form) - (write-string form stream)) + (write-string form stream)) (t - (princ form stream)))) + (princ form stream)))) (ent - (funcall print-handler - ent - :full - (when (consp (car form)) (cdr (car form))) - form - subst - unknown - stream)) + (funcall print-handler + ent + :full + (when (consp (car form)) (cdr (car form))) + form + subst + unknown + stream)) (t (error "Illegal form: ~s" form))))) - + (defun html-find-value (key subst) ; find the (key . value) object in the subst list. ; A subst list is an assoc list ((key . value) ....) ; but instead of a (key . value) cons you may have an assoc list ; (let ((to-process nil) - (alist subst)) + (alist subst)) (loop (do* ((entlist alist (cdr entlist)) - (ent (car entlist) (car entlist))) - ((null entlist) (setq alist nil)) - (cond - ((consp (car ent)) - ;; this is another alist - (when (cdr entlist) - (push (cdr entlist) to-process)) - (setq alist ent) - (return)) ; exit do* - ((equal key (car ent)) - (return-from html-find-value ent)))) - + (ent (car entlist) (car entlist))) + ((null entlist) (setq alist nil)) + (cond + ((consp (car ent)) + ;; this is another alist + (when (cdr entlist) + (push (cdr entlist) to-process)) + (setq alist ent) + (return)) ; exit do* + ((equal key (car ent)) + (return-from html-find-value ent)))) + (when (null alist) - ;; we need to find a new alist to process - (if to-process - (setq alist (pop to-process)) - (return)))))) + ;; we need to find a new alist to process + (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 @@ -488,42 +488,42 @@ (:full ; set, do body and then unset (let (iter) (if args - (cond - ((and (setq iter (getf args :iter)) - (setq iter (html-find-value iter subst))) - ;; remove the iter and pre - (setq args (copy-list args)) - (remf args :iter) - (funcall (cdr iter) - (cons (cons (caar form) - args) - (cdr form)) - subst - stream) - (return-from html-standard-print)) - (t - (format stream "<~a" (html-process-key ent)) - (do ((xx args (cddr xx))) - ((null xx)) - ; assume that the arg is already escaped - ; since we read it - ; from the parser - (format stream " ~a=\"~a\"" (car xx) (cadr xx))) - (format stream ">"))) - (format stream "<~a>" (html-process-key ent))) + (cond + ((and (setq iter (getf args :iter)) + (setq iter (html-find-value iter subst))) + ;; remove the iter and pre + (setq args (copy-list args)) + (remf args :iter) + (funcall (cdr iter) + (cons (cons (caar form) + args) + (cdr form)) + subst + stream) + (return-from html-standard-print)) + (t + (format stream "<~a" (html-process-key ent)) + (do ((xx args (cddr xx))) + ((null xx)) + ; assume that the arg is already escaped + ; since we read it + ; from the parser + (format stream " ~a=\"~a\"" (car xx) (cadr xx))) + (format stream ">"))) + (format stream "<~a>" (html-process-key ent))) (dolist (ff (cdr form)) - (html-print-subst ff subst stream unknown))) + (html-print-subst ff subst stream unknown))) (when (html-process-has-inverse ent) ;; end the form (format stream "" (html-process-key ent)))))) - - - - - - - - + + + + + + + + ;; -- defining how html tags are handled. -- ;; ;; most tags are handled in a standard way and the def-std-html @@ -533,34 +533,34 @@ ;; how these are handled. The tags requiring special treatment ;; are the pseudo tags we added to control operations ;; in the html generator. -;; +;; ;; ;; tags can be found in three ways: -;; :br - singleton, no attributes, no body +;; :br - singleton, no attributes, no body ;; (:b "foo") - no attributes but with a body ;; ((:a href="foo") "balh") - attributes and body ;; - - + + (defmacro def-special-html (kwd fcn print-fcn) ;; kwd - the tag we're defining behavior for. ;; fcn - function to compute the macroexpansion of a use of this - ;; tag. args to fcn are: - ;; ent - html-process object holding info on this tag - ;; args - list of attribute-values following tag - ;; argsp - true if there is a body in this use of the tag - ;; body - list of body forms. - ;; print-fcn - function to print an lhtml form with this tag - ;; args to fcn are: - ;; ent - html-process object holding info on this tag - ;; cmd - one of :set, :unset, :full - ;; args - list of attribute-value pairs - ;; subst - subsitution list - ;; unknown - function to call for unknown tags - ;; stream - stream to write to - ;; - `(setf (gethash ,kwd *html-process-table*) + ;; tag. args to fcn are: + ;; ent - html-process object holding info on this tag + ;; args - list of attribute-values following tag + ;; argsp - true if there is a body in this use of the tag + ;; body - list of body forms. + ;; print-fcn - function to print an lhtml form with this tag + ;; args to fcn are: + ;; ent - html-process object holding info on this tag + ;; cmd - one of :set, :unset, :full + ;; args - list of attribute-value pairs + ;; subst - subsitution list + ;; unknown - function to call for unknown tags + ;; stream - stream to write to + ;; + `(setf (gethash ,kwd *html-process-table*) (make-html-process ,kwd nil nil ,fcn ,print-fcn nil))) @@ -568,91 +568,91 @@ (declare (ignore name)) `(function ,@body)) - -(def-special-html :newline + +(def-special-html :newline (named-function html-newline-function (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - (when body - (error "can't have a body with :newline -- body is ~s" body)) - `(terpri *html-stream*))) - + (declare (ignore ent args argsp)) + (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) - (terpri stream) - (error ":newline in an illegal place: ~s" form))))) + (terpri stream) + (error ":newline in an illegal place: ~s" form))))) (def-special-html :princ (named-function html-princ-function (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(princ-http ,bod)) - body)))) - + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-http ,bod)) + body)))) + (named-function html-princ-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) - (format stream "~a" (cadr form)) - (error ":princ must be given an argument"))))) + (format stream "~a" (cadr form)) + (error ":princ must be given an argument"))))) -(def-special-html :princ-safe +(def-special-html :princ-safe (named-function html-princ-safe-function (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(princ-safe-http ,bod)) - body)))) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-safe-http ,bod)) + body)))) (named-function html-princ-safe-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) - (emit-safe stream (format nil "~a" (cadr form))) - (error ":princ-safe must be given an argument"))))) + (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 (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(prin1-http ,bod)) - body)))) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-http ,bod)) + body)))) (named-function html-prin1-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore ent args unknown subst)) (assert (eql 2 (length form))) (if (eq cmd :full) - (format stream "~s" (cadr form)) - (error ":prin1 must be given an argument"))))) + (format stream "~s" (cadr form)) + (error ":prin1 must be given an argument"))))) (def-special-html :prin1-safe (named-function html-prin1-safe-function (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - `(progn ,@(mapcar #'(lambda (bod) - `(prin1-safe-http ,bod)) - body)))) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-safe-http ,bod)) + body)))) (named-function html-prin1-safe-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore args ent subst unknown)) (assert (eql 2 (length form))) (if (eq cmd :full) - (emit-safe stream (format nil "~s" (cadr form))) - (error ":prin1-safe must be given an argument"))))) + (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 (lambda (ent args argsp body) - ;; must use syntax - (declare (ignore ent args argsp)) - `(progn (write-string "" *html-stream*)))) + ;; must use syntax + (declare (ignore ent args argsp)) + `(progn (write-string "" *html-stream*)))) (named-function html-comment-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore ent cmd args subst unknown)) @@ -662,17 +662,17 @@ (defmacro def-std-html (kwd has-inverse name-attrs) (let ((mac-name (intern (format nil "~a-~a" :with-html kwd))) - (string-code (string-downcase (string kwd)))) + (string-code (string-downcase (string kwd)))) `(progn (setf (gethash ,kwd *html-process-table*) - (make-html-process ,kwd ,has-inverse - ',mac-name - nil - #'html-standard-print - ',name-attrs)) - (defmacro ,mac-name (args &rest body) - (html-body-key-form ,string-code ,has-inverse args body))))) + (make-html-process ,kwd ,has-inverse + ',mac-name + nil + #'html-standard-print + ',name-attrs)) + (defmacro ,mac-name (args &rest body) + (html-body-key-form ,string-code ,has-inverse args body))))) + - (def-std-html :a t nil) (def-std-html :abbr t nil) @@ -735,72 +735,72 @@ (def-std-html :ins t nil) (def-std-html :isindex nil nil) -(def-std-html :kbd t nil) -(def-std-html :keygen nil nil) +(def-std-html :kbd t nil) +(def-std-html :keygen nil nil) -(def-std-html :label t nil) -(def-std-html :layer t nil) -(def-std-html :legend t nil) -(def-std-html :li t nil) -(def-std-html :link nil nil) +(def-std-html :label t nil) +(def-std-html :layer t nil) +(def-std-html :legend t nil) +(def-std-html :li t nil) +(def-std-html :link nil nil) (def-std-html :listing t nil) -(def-std-html :map t nil) +(def-std-html :map t nil) (def-std-html :marquee t nil) -(def-std-html :menu t nil) -(def-std-html :meta nil nil) +(def-std-html :menu t nil) +(def-std-html :meta nil nil) (def-std-html :multicol t nil) -(def-std-html :nobr t nil) +(def-std-html :nobr t nil) (def-std-html :noembed t nil) (def-std-html :noframes t nil) (def-std-html :noscript t nil) -(def-std-html :object t nil) -(def-std-html :ol t nil) +(def-std-html :object t nil) +(def-std-html :ol t nil) (def-std-html :optgroup t nil) -(def-std-html :option t nil) +(def-std-html :option t nil) -(def-std-html :p t nil) -(def-std-html :param t nil) +(def-std-html :p t nil) +(def-std-html :param t nil) (def-std-html :plaintext nil nil) -(def-std-html :pre t nil) - -(def-std-html :q t nil) - -(def-std-html :s t nil) -(def-std-html :samp t nil) -(def-std-html :script t nil) -(def-std-html :select t nil) -(def-std-html :server t nil) -(def-std-html :small t nil) -(def-std-html :spacer nil nil) -(def-std-html :span t :id) -(def-std-html :strike t nil) -(def-std-html :strong t nil) -(def-std-html :style t nil) -(def-std-html :sub t nil) -(def-std-html :sup t nil) - -(def-std-html :table t :name) -(def-std-html :tbody t nil) -(def-std-html :td t nil) +(def-std-html :pre t nil) + +(def-std-html :q t nil) + +(def-std-html :s t nil) +(def-std-html :samp t nil) +(def-std-html :script t nil) +(def-std-html :select t nil) +(def-std-html :server t nil) +(def-std-html :small t nil) +(def-std-html :spacer nil nil) +(def-std-html :span t :id) +(def-std-html :strike t nil) +(def-std-html :strong t nil) +(def-std-html :style t nil) +(def-std-html :sub t nil) +(def-std-html :sup t nil) + +(def-std-html :table t :name) +(def-std-html :tbody t nil) +(def-std-html :td t nil) (def-std-html :textarea t nil) -(def-std-html :tfoot t nil) -(def-std-html :th t nil) -(def-std-html :thead t nil) -(def-std-html :title t nil) -(def-std-html :tr t nil) -(def-std-html :tt t nil) +(def-std-html :tfoot t nil) +(def-std-html :th t nil) +(def-std-html :thead t nil) +(def-std-html :title t nil) +(def-std-html :tr t nil) +(def-std-html :tt t nil) -(def-std-html :u t nil) -(def-std-html :ul t nil) +(def-std-html :u t nil) +(def-std-html :ul t nil) -(def-std-html :var t nil) +(def-std-html :var t nil) -(def-std-html :wbr nil nil) +(def-std-html :wbr nil nil) -(def-std-html :xmp t nil) +(def-std-html :xmp t nil) @@ -810,111 +810,111 @@ (def-special-html :jscript (named-function html-comment-function (lambda (ent args argsp body) - ;; must use syntax - (declare (ignore ent args argsp)) - `(progn - #+ignore - (write-string "" *html-stream*)))) + ;; must use syntax + (declare (ignore ent args argsp)) + `(progn + #+ignore + (write-string "" *html-stream*)))) (named-function html-comment-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore ent cmd args subst unknown)) (format stream "" - (cadr form))))) + (cadr form))))) -(def-special-html :nbsp +(def-special-html :nbsp (named-function html-nbsp-function (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - (when body - (error "can't have a body with :nbsp -- body is ~s" body)) - `(write-string " " *html-stream*))) - + (declare (ignore ent args argsp)) + (when body + (error "can't have a body with :nbsp -- body is ~s" body)) + `(write-string " " *html-stream*))) + (named-function html-nbsp-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore args ent unknown subst)) (if (eq cmd :set) - (write-string " " stream) - (error ":nbsp in an illegal place: ~s" form))))) + (write-string " " stream) + (error ":nbsp in an illegal place: ~s" form))))) (def-special-html :load-file (named-function html-nbsp-function (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - (unless body - (error "must have a body with :load-file")) - `(progn ,@(mapcar #'(lambda (bod) - `(lml-load ,bod)) - body)))) - + (declare (ignore ent args argsp)) + (unless body + (error "must have a body with :load-file")) + `(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)) (assert (eql 2 (length form))) (if (eq cmd :full) - (lml-load (cadr form)) - (error ":load-file must be given an argument"))))) + (lml-load (cadr form)) + (error ":load-file must be given an argument"))))) (def-special-html :insert-file (named-function html-nbsp-function (lambda (ent args argsp body) - (declare (ignore ent args argsp)) - (unless body - (error "must have a body with :insert-file")) - `(progn ,@(mapcar #'(lambda (bod) - `(insert-file ,bod)) - body)))) - + (declare (ignore ent args argsp)) + (unless body + (error "must have a body with :insert-file")) + `(progn ,@(mapcar #'(lambda (bod) + `(insert-file ,bod)) + body)))) + (named-function html-nbsp-print-function (lambda (ent cmd args form subst unknown stream) (declare (ignore ent unknown subst stream args)) (assert (eql 2 (length form))) (if (eq cmd :full) - (insert-file (cadr form)) - (error ":insert-file must be given an argument"))))) + (insert-file (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)) - (if (= (length body) 1) - `(write-string ,(car body) *html-stream*) - `(progn ,@(mapcar #'(lambda (bod) - `(write-string ,bod *html-stream*)) - body))))) - + (declare (ignore ent args argsp)) + (if (= (length body) 1) + `(write-string ,(car body) *html-stream*) + `(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"))))) + (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)))) - + (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"))))) + (write-char (cadr form) stream) + (error ":write-char must be given an argument"))))) diff --git a/package.lisp b/package.lisp index a1a4420..5d93991 100644 --- a/package.lisp +++ b/package.lisp @@ -23,7 +23,7 @@ ;; data.lisp #:*html-stream* - + ;; base.lisp #:html-file-page #:dtd-prologue @@ -35,7 +35,7 @@ #:lml-print-date #:alink #:alink-c - + ;; htmlgen.lisp #:html #:html-print #:html-print-subst #:html-print-list #:html-print-list-subst #:html-stream #:*html-stream* @@ -53,7 +53,7 @@ #:std-body #:std-head #:titled-pre-section - + ;; downloads.lisp #:std-dl-page #:full-dl-page diff --git a/read-macro.lisp b/read-macro.lisp index 8e97b9d..0e173eb 100644 --- a/read-macro.lisp +++ b/read-macro.lisp @@ -23,58 +23,58 @@ #'(lambda (stream char) (declare (ignore char)) (let ((forms '()) - (curr-string (new-string)) - (paren-level 0) - (got-comma nil)) - (declare (type fixnum paren-level)) - (do ((ch (read-char stream t nil t) (read-char stream t nil t))) - ((eql ch #\])) - (if got-comma - (if (eql ch #\() - ;; Starting top-level ,( - (progn - #+cmu - (setf curr-string (coerce curr-string `(simple-array character (*)))) - - (push `(lml2-princ ,curr-string) forms) - (setq curr-string (new-string)) - (setq got-comma nil) - (vector-push #\( curr-string) - (do ((ch (read-char stream t nil t) (read-char stream t nil t))) - ((and (eql ch #\)) (zerop paren-level))) - (when (eql ch #\]) - (format *trace-output* "Syntax error reading #\]") - (return nil)) - (case ch - (#\( - (incf paren-level)) - (#\) - (decf paren-level))) - (vector-push-extend ch curr-string)) - (vector-push-extend #\) curr-string) - (let ((eval-string (read-from-string curr-string)) - (res (gensym))) - (push - `(let ((,res ,eval-string)) - (when ,res - (lml2-princ ,res))) - forms)) - (setq curr-string (new-string))) - ;; read comma, then non #\( char - (progn - (unless (eql ch #\,) - (setq got-comma nil)) - (vector-push-extend #\, curr-string) ;; push previous command - (vector-push-extend ch curr-string))) - ;; previous character is not a comma - (if (eql ch #\,) - (setq got-comma t) - (progn - (setq got-comma nil) - (vector-push-extend ch curr-string))))) + (curr-string (new-string)) + (paren-level 0) + (got-comma nil)) + (declare (type fixnum paren-level)) + (do ((ch (read-char stream t nil t) (read-char stream t nil t))) + ((eql ch #\])) + (if got-comma + (if (eql ch #\() + ;; Starting top-level ,( + (progn + #+cmu + (setf curr-string (coerce curr-string `(simple-array character (*)))) - #+cmu - (setf curr-string (coerce curr-string `(simple-array character (*)))) - - (push `(lml2-princ ,curr-string) forms) - `(progn ,@(nreverse forms))))) + (push `(lml2-princ ,curr-string) forms) + (setq curr-string (new-string)) + (setq got-comma nil) + (vector-push #\( curr-string) + (do ((ch (read-char stream t nil t) (read-char stream t nil t))) + ((and (eql ch #\)) (zerop paren-level))) + (when (eql ch #\]) + (format *trace-output* "Syntax error reading #\]") + (return nil)) + (case ch + (#\( + (incf paren-level)) + (#\) + (decf paren-level))) + (vector-push-extend ch curr-string)) + (vector-push-extend #\) curr-string) + (let ((eval-string (read-from-string curr-string)) + (res (gensym))) + (push + `(let ((,res ,eval-string)) + (when ,res + (lml2-princ ,res))) + forms)) + (setq curr-string (new-string))) + ;; read comma, then non #\( char + (progn + (unless (eql ch #\,) + (setq got-comma nil)) + (vector-push-extend #\, curr-string) ;; push previous command + (vector-push-extend ch curr-string))) + ;; previous character is not a comma + (if (eql ch #\,) + (setq got-comma t) + (progn + (setq got-comma nil) + (vector-push-extend ch curr-string))))) + + #+cmu + (setf curr-string (coerce curr-string `(simple-array character (*)))) + + (push `(lml2-princ ,curr-string) forms) + `(progn ,@(nreverse forms))))) diff --git a/stdsite.lisp b/stdsite.lisp index 14fb961..ac3ee63 100644 --- a/stdsite.lisp +++ b/stdsite.lisp @@ -30,7 +30,7 @@ (defmacro std-head (title &body body) `(html - (:head + (:head (:title (:princ ,title)) (lml-load "header.lml_") ,@body))) @@ -40,13 +40,13 @@ (html ((:div :class "disclaimsec") (let ((src-file (make-pathname - :defaults *sources-dir* - :type "lml" - :name (pathname-name file)))) + :defaults *sources-dir* + :type "lml" + :name (pathname-name file)))) (when (probe-file src-file) - (html - ((:div :class "lastmod") - (lml-format "Last modified: ~A" (date-string (file-write-date src-file))))))) + (html + ((:div :class "lastmod") + (lml-format "Last modified: ~A" (date-string (file-write-date src-file))))))) (lml-load "footer.lml_")))) @@ -55,17 +55,17 @@ (:body (lml-load "banner.lml_") ((:table :class "stdbodytable" :border "0" :cellpadding "3") - (:tbody + (:tbody ((:tr :valign "top") - ((:td :class "stdcontentcell") - (lml-load "contents.lml_")) - ((:td :valign "top") - ,@body - (std-footer ,file)) + ((:td :class "stdcontentcell") + (lml-load "contents.lml_")) + ((:td :valign "top") + ,@body + (std-footer ,file)) ((:td :valign "top") (lml-load "rightcol.lml_" :optional t))))) (lml-load "final.lml_" :optional t)))) - + (defmacro print-std-page (file title format &body body) `(progn @@ -76,11 +76,11 @@ (std-body ,file ,@body))))) (defmacro std-page ((out-file title &key (format :xhtml11)) - &body body) + &body body) `(let ((*indent* 0)) (with-open-file (*html-stream* (lml-file-name ',out-file :output) - :direction :output - :if-exists :supersede) + :direction :output + :if-exists :supersede) (print-std-page (lml-file-name ',out-file :source) ,title ,format ,@body)))) (defmacro titled-pre-section (title &body body) diff --git a/utils.lisp b/utils.lisp index 16f3e26..6cfb904 100644 --- a/utils.lisp +++ b/utils.lisp @@ -29,4 +29,4 @@ (if stream `(funcall (formatter ,control-string) ,stream ,@args) `(format nil ,control-string ,@args))) - + -- 2.34.1