(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
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">"
((: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 "<hr noshade align=\"left\" width=\"80%\">")
- :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 "<hr noshade align=\"left\" width=\"80%\">")
+ :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 "<hr noshade align=\"left\" width=\"80%\">")
:newline
(when address
- (html-stream
- stream
- (:address address))))))))
+ (html-stream
+ stream
+ (:address address))))))))
(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*))
(lml-write-string (date-string date)))
(defun xml-header-stream (stream &key (version "1.0") (standalone :unspecified)
- (encoding :unspecified))
+ (encoding :unspecified))
(format stream "<?xml version=\"~A\"~A~A ?>"
- 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)
(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 #\[)
(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
(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 href=\"~A~A\">~A</a>"
- (dl-data-url dl-data) dl-name basename)
+ (dl-data-url dl-data) dl-name basename)
(lml-princ "<span class=\"modtime\">")
(lml-format " (~A, <b>~:D <span style=\"font-size:90%;\">KB</span></b>)</span>" modtime size)
(when (probe-file sig-path)
- (setf (dl-data-signed dl-data) t)
- (lml-format " [<a href=\"~A~A.asc\">Signature</a>]"
- (dl-data-url dl-data) dl-name))
+ (setf (dl-data-signed dl-data) t)
+ (lml-format " [<a href=\"~A~A.asc\">Signature</a>]"
+ (dl-data-url dl-data) dl-name))
(html :br))))
(defun display-header (name url)
(lml-princ "<h3>GPG Public Key</h3>")
(lml-princ "Use this <a href=\"https://www.b9.com/kevin.gpg.asc\">key</a> to verify file signtatures"))
(lml-princ "</div>"))
-
+
(defun print-sect-title (title dl-data)
(lml-format "<h~D>~A</h~D>"
- (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)))
(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))))
(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 "<div style=\"padding-left: 20pt;\">")
(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))
(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))))))))
(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)
(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))
;;
;; $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:
;; - 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
(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
)
-(defparameter *html-process-table*
+(defparameter *html-process-table*
(make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
)
"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
(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)
(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 "</~a>" 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 "</~a>" 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 "</~a>" 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 "</~a>" string-code)
+ *html-stream*)))
(if has-inv
- `(progn (write-string ,(format nil "<~a>" string-code)
- *html-stream*)
- ,@body
- ,(when body
- `(write-string ,(format nil "</~a>" string-code)
- *html-stream*)))
+ `(progn (write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ ,@body
+ ,(when body
+ `(write-string ,(format nil "</~a>" string-code)
+ *html-stream*)))
`(progn (write-string ,(format nil "<~a />" string-code)
- *html-stream*)))))
+ *html-stream*)))))
;; 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))))
"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
(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
(: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 "</~a>" (html-process-key ent))))))
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
;; -- defining how html tags are handled. --
;;
;; most tags are handled in a standard way and the def-std-html
;; 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)))
(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*)
- (html ,@body)
- (write-string "-->" *html-stream*))))
+ ;; must use <!-- --> syntax
+ (declare (ignore ent args argsp))
+ `(progn (write-string "<!--" *html-stream*)
+ (html ,@body)
+ (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))
(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)
(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)
(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 "<script language=\"JavaScript\" type=\"text/javascript\">" *html-stream*)
- (write-string "<script type=\"text/javascript\">" *html-stream*)
- (write-char #\newline *html-stream*)
- (write-string "// <![CDATA[" *html-stream*)
- (write-char #\newline *html-stream*)
- (html ,@body)
- (write-char #\newline *html-stream*)
- (write-string "// ]]>" *html-stream*)
- (write-char #\newline *html-stream*)
- (write-string "</script>" *html-stream*))))
+ ;; must use <!-- --> syntax
+ (declare (ignore ent args argsp))
+ `(progn
+ #+ignore
+ (write-string "<script language=\"JavaScript\" type=\"text/javascript\">" *html-stream*)
+ (write-string "<script type=\"text/javascript\">" *html-stream*)
+ (write-char #\newline *html-stream*)
+ (write-string "// <![CDATA[" *html-stream*)
+ (write-char #\newline *html-stream*)
+ (html ,@body)
+ (write-char #\newline *html-stream*)
+ (write-string "// ]]>" *html-stream*)
+ (write-char #\newline *html-stream*)
+ (write-string "</script>" *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 "<script language=\"JavaScript\" type=\"text/javascript\">~%// <![CDATA[~%~A~%// ]]>~%</script>"
- (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")))))
;; data.lisp
#:*html-stream*
-
+
;; base.lisp
#:html-file-page
#:dtd-prologue
#: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*
#:std-body
#:std-head
#:titled-pre-section
-
+
;; downloads.lisp
#:std-dl-page
#:full-dl-page
#'(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)))))
(defmacro std-head (title &body body)
`(html
- (:head
+ (:head
(:title (:princ ,title))
(lml-load "header.lml_")
,@body)))
(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_"))))
(: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
(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)
(if stream
`(funcall (formatter ,control-string) ,stream ,@args)
`(format nil ,control-string ,@args)))
-
+
(defmacro with-functions (&rest slots)
`(progn ,@(loop for (fn description . args) in slots collect
- `(with-function-info (,fn ,@(if args args
- '(connection-variable)))
+ `(with-function-info (,fn ,@(if args args
+ '(connection-variable)))
,description))))
(when (streamp *html-output*)
(when *print-spaces* (indent-spaces *indent* *html-output*))
(if args
- (apply #'format *html-output* str args)
+ (apply #'format *html-output* str args)
(write-string str *html-output*))
(when *print-spaces* (write-char #\newline *html-output*))))
`(progn
,@(mapcar
#'(lambda (form)
- (etypecase form
- (string
- `(lml-princ ,form))
- (number
- `(lml-format "~D" ,form))
- (symbol
- (when form
- `(lml-princ ,form)))
- (cons
- form)))
+ (etypecase form
+ (string
+ `(lml-princ ,form))
+ (number
+ `(lml-format "~D" ,form))
+ (symbol
+ (when form
+ `(lml-princ ,form)))
+ (cons
+ form)))
forms)))
(defmacro with-attr-string (tag attr-string &body body)
(let ((attr (gensym)))
`(let ((,attr ,attr-string))
(lml-format "<~(~A~)~A>" ',tag
- (if (and (stringp ,attr) (plusp (length ,attr)))
- (format nil " ~A" ,attr)
- ""))
+ (if (and (stringp ,attr) (plusp (length ,attr)))
+ (format nil " ~A" ,attr)
+ ""))
(incf *indent*)
(lml-exec-body ,@body)
(decf *indent*)
(let ((attr (gensym)))
`(let ((,attr ,attr-string))
(lml-format "<~(~A~)~A />" ',tag
- (if (and (stringp ,attr) (plusp (length ,attr)))
- (format nil " ~A" ,attr)
- "")))))
+ (if (and (stringp ,attr) (plusp (length ,attr)))
+ (format nil " ~A" ,attr)
+ "")))))
(defun one-keyarg-string (key value)
"Return attribute string for keys"
(format nil "~(~A~)=\"~A\"" key
- (typecase value
- (symbol
- (string-downcase (symbol-name value)))
- (string
- value)
- (t
- (eval value)))))
+ (typecase value
+ (symbol
+ (string-downcase (symbol-name value)))
+ (string
+ value)
+ (t
+ (eval value)))))
(defmacro with-keyargs (tag keyargs &body body)
(let ((attr (gensym))
- (kv (gensym)))
+ (kv (gensym)))
`(progn
(let ((,attr '()))
(dolist (,kv ,keyargs)
- (awhen (cdr ,kv)
- (push (one-keyarg-string (car ,kv) it) ,attr)))
+ (awhen (cdr ,kv)
+ (push (one-keyarg-string (car ,kv) it) ,attr)))
(with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
(defmacro with-no-endtag-keyargs (tag keyargs)
(let ((attr (gensym))
- (kv (gensym)))
+ (kv (gensym)))
`(progn
(let ((,attr '()))
(dolist (,kv ,keyargs)
- (awhen (cdr ,kv)
- (push (one-keyarg-string (car ,kv) it) ,attr)))
+ (awhen (cdr ,kv)
+ (push (one-keyarg-string (car ,kv) it) ,attr)))
(with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr)))))))
(defmacro bind-one-keyarg (keyarg)
(defmacro bind-all-keyargs (keyargs)
"Convert a list of keyarg pairs and convert eval/bind arguments"
(let* ((npairs (length keyargs))
- (syms (make-array npairs))
- (ipair 0)
- (ipair2 0))
+ (syms (make-array npairs))
+ (ipair 0)
+ (ipair2 0))
(declare (dynamic-extent syms))
(dotimes (i npairs)
(setf (aref syms i) (gensym)))
`(let ,(mapcar #'(lambda (ka)
- (prog1
- (list (aref syms ipair) (cdr ka))
- (incf ipair)))
- keyargs)
+ (prog1
+ (list (aref syms ipair) (cdr ka))
+ (incf ipair)))
+ keyargs)
(list ,@(mapcar #'(lambda (ka)
- (prog1
- `(cons ,(car ka) ,(aref syms ipair2))
- (incf ipair2)))
- keyargs)))))
+ (prog1
+ `(cons ,(car ka) ,(aref syms ipair2))
+ (incf ipair2)))
+ keyargs)))))
(defmacro with (tag &rest args)
"Return a list of keyargs and also the body of LML form"
(let ((body '())
- (keyargs '())
- (bound-keyargs (gensym)))
+ (keyargs '())
+ (bound-keyargs (gensym)))
(do* ((n (length args))
- (i 0 (+ 2 i))
- (arg (nth i args) (nth i args))
- (value (when (< (1+ i) n)
- (nth (1+ i) args))
- (when (< (1+ i) n)
- (nth (1+ i) args))))
- ((or (not (keyword-symbol? arg))
- (>= i n))
- (dotimes (j (- n i))
- (push (nth (+ i j) args) body)))
+ (i 0 (+ 2 i))
+ (arg (nth i args) (nth i args))
+ (value (when (< (1+ i) n)
+ (nth (1+ i) args))
+ (when (< (1+ i) n)
+ (nth (1+ i) args))))
+ ((or (not (keyword-symbol? arg))
+ (>= i n))
+ (dotimes (j (- n i))
+ (push (nth (+ i j) args) body)))
(push (cons arg value) keyargs))
(setq keyargs (nreverse keyargs))
(setq body (nreverse body))
(defmacro with-no-endtag (tag &rest args)
"Return a list of keyargs body of LML form"
(let ((keyargs '())
- (bound-keyargs (gensym)))
+ (bound-keyargs (gensym)))
(do* ((n (length args))
- (i 0 (+ 2 i))
- (arg (nth i args) (nth i args))
- (value (when (< (1+ i) n)
- (nth (1+ i) args))
- (when (< (1+ i) n)
- (nth (1+ i) args))))
- ((or (not (keyword-symbol? arg))
- (>= i n)))
+ (i 0 (+ 2 i))
+ (arg (nth i args) (nth i args))
+ (value (when (< (1+ i) n)
+ (nth (1+ i) args))
+ (when (< (1+ i) n)
+ (nth (1+ i) args))))
+ ((or (not (keyword-symbol? arg))
+ (>= i n)))
(push (cons arg value) keyargs))
(setq keyargs (nreverse keyargs))
`(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
(defmacro jscript (&body body)
`(with script :language "JavaScript" :type "text/javascript"
- ,@body))
+ ,@body))
(defmacro xhtml-prologue ()
`(progn
(let ((name (intern (format nil "~A-~A" tag :c))))
`(progn
(defmacro ,name (&body body)
- `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
+ `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
(export ',name))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro page (out-file &body body)
`(with-open-file (*html-output*
- (lml-file-name ',out-file :output)
- :direction :output
- :if-exists :supersede)
+ (lml-file-name ',out-file :output)
+ :direction :output
+ :if-exists :supersede)
(xhtml-prologue)
(html :xmlns "http://www.w3.org/1999/xhtml"
,@body)))
-
+
(defun strip-dl-base (file)
(let ((fdir (pathname-directory file))
- (bdir (pathname-directory *dl-base*)))
+ (bdir (pathname-directory *dl-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)
(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))
- (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))
+ (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 href=\"~A~A\">~A</a>" *dl-url* dl-name basename)
(lml-princ "<span class=\"modtime\">")
(lml-format " (~A, <b>~:D <span style=\"font-size:90%;\">KB</span></b>)</span>" modtime size)
(when (probe-file sig-path)
- (setq *signed* t)
- (lml-format " [<a href=\"~A~A.asc\">Signature</a>]" *dl-url* dl-name))
+ (setq *signed* t)
+ (lml-format " [<a href=\"~A~A.asc\">Signature</a>]" *dl-url* dl-name))
(br))))
(defun display-header (name url)
(lml-princ "<h3>GPG Public Key</h3>")
(lml-princ "Use this <a href=\"https://www.b9.com/kevin.gpg.asc\">key</a> to verify file signtatures"))
(lml-princ "</div>"))
-
+
(defun print-sect-title (title)
(lml-format "<h~D>~A</h~D>" *section-indent* title *section-indent*))
(defun match-base-name-latest? (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))))
(defun display-one-section (title pat)
(let ((files (sort-pathnames (filter-latest
- (filter-against-base (directory pat))))))
+ (filter-against-base (directory pat))))))
(when files
(print-sect-title title)
(lml-princ "<div style=\"padding-left: 20pt;\">")
(defun display-sections (sects)
(when sects
(let ((title (car sects))
- (value (cadr sects)))
+ (value (cadr sects)))
(if (consp title)
- (dolist (sect sects) (display-sections sect))
- (if (consp value)
- (progn
- (print-sect-title title)
- (incf *section-indent*)
- (display-sections value)
- (decf *section-indent*))
- (display-one-section title value))))))
-
+ (dolist (sect sects) (display-sections sect))
+ (if (consp value)
+ (progn
+ (print-sect-title title)
+ (incf *section-indent*)
+ (display-sections value)
+ (decf *section-indent*))
+ (display-one-section title value))))))
+
(defun display-page (pkg-name pkg-base dl-base dl-url sects)
(let ((*section-indent* 3)
- (*dl-base* dl-base)
- (*dl-url* dl-url)
- (*base-name* pkg-base)
- (*signed* nil))
+ (*dl-base* dl-base)
+ (*dl-url* dl-url)
+ (*base-name* pkg-base)
+ (*signed* nil))
(display-header pkg-name dl-url)
(map nil #'display-sections sects)
(display-footer)))
(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))))))))
(setq f (concatenate 'string f ".html"))))
(if *sources-dir*
(make-pathname :defaults (ecase type
- (:source *sources-dir*)
- (:output *output-dir*))
- :name (pathname-name f)
- :type (pathname-type f))
+ (:source *sources-dir*)
+ (:output *output-dir*))
+ :name (pathname-name f)
+ :type (pathname-type f))
(if (stringp f)
- (nth-value 0 (parse-namestring f))
- f)))
+ (nth-value 0 (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)
(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)
(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)))
(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)
(lml-load-path (eval `(lml-file-name ,file :source))))
#:lml-write-string
#:lml-print-date
#:*html-output*
-
+
;; files.lisp
#:with-dir
#:process-dir
#:std-body
#:std-head
#:titled-pre-section
-
+
;; downloads.lisp
#:std-dl-page
#:full-dl-page
#'(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 `(lml-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
- (lml-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 `(lml-princ ,curr-string) forms)
- `(progn ,@(nreverse forms)))))
+ (push `(lml-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
+ (lml-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 `(lml-princ ,curr-string) forms)
+ `(progn ,@(nreverse forms)))))
(in-package #:lml)
(defmacro std-head (title &body body)
- `(head
+ `(head
(title ,title)
(lml-load "head.lml_")
,@body))
(defun std-footer (file)
(div-c "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)
- (div-c "lastmod"
+ (div-c "lastmod"
(lml-format "Last modified: ~A" (date-string (file-write-date src-file))))))
(lml-load "footer.lml_"))
(values))
(defmacro std-body (file &body body)
`(body
(lml-load "banner.lml_")
- (table-c "stdbodytable" :border "0" :cellpadding "3"
- (tbody
- (tr :valign "top"
- (td-c "stdcontentcell"
- (lml-load "contents.lml_"))
- (td :valign "top"
- ,@body
- (std-footer ,file)))))
+ (table-c "stdbodytable" :border "0" :cellpadding "3"
+ (tbody
+ (tr :valign "top"
+ (td-c "stdcontentcell"
+ (lml-load "contents.lml_"))
+ (td :valign "top"
+ ,@body
+ (std-footer ,file)))))
(lml-load "final.lml_")))
-
+
(defmacro print-std-page (file title &body body)
`(progn
(xhtml-prologue)
(html :xmlns "http://www.w3.org/1999/xhtml"
- (std-head ,title)
- (std-body ,file ,@body))))
+ (std-head ,title)
+ (std-body ,file ,@body))))
(defmacro std-page (out-file title &body body)
`(let ((*indent* 0))
(with-open-file (*html-output* (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 ,@body))))
(defmacro titled-pre-section (title &body body)
`(progn
(h1 ,title)
(pre :style "padding-left:30pt;"
- ,@body)))
+ ,@body)))
(deftest lml.3
(with-output-to-string (s)
(let ((*html-output* s)
- (a 5.5d0))
+ (a 5.5d0))
(p a)))
"<p>5.5d0</p>")
(deftest lml.4
(with-output-to-string (s)
(let ((*html-output* s)
- (a 0.75))
+ (a 0.75))
(img "http://localhost/test.png" :width a)))
"<img src=\"http://localhost/test.png\" width=\"0.75\" />")
(with-output-to-string (s)
(let ((*html-output* s))
(div "Start"
- (p "Testing"))))
+ (p "Testing"))))
"<div>Start<p>Testing</p></div>")
(deftest lml.6
(with-output-to-string (s)
(let ((*html-output* s))
(div :style "font-weight:bold"
- "Start"
- (p-c a_class "Testing"))))
+ "Start"
+ (p-c a_class "Testing"))))
"<div style=\"font-weight:bold\">Start<p class=\"a_class\">Testing</p></div>")
(defun print-n-chars (char n stream)
(declare (fixnum n)
- (optimize (speed 3) (safety 0) (space 0)))
+ (optimize (speed 3) (safety 0) (space 0)))
(do ((i 0 (1+ i)))
((= i n) char)
(declare (fixnum i))
(write-char char stream)))
-
+
(defun indent-spaces (n &optional (stream *standard-output*))
"Indent n*2 spaces to output stream"
(print-n-chars #\space (+ n n) stream))
"Opens a reads a file. Returns the contents as a single string"
(when (probe-file file)
(with-open-file (in file :direction :input)
- (do ((line (read-line in nil 'eof)
- (read-line in nil 'eof)))
- ((eql line 'eof))
- (write-string line strm)
- (write-char #\newline strm)))))
+ (do ((line (read-line in nil 'eof)
+ (read-line in nil 'eof)))
+ ((eql line 'eof))
+ (write-string line strm)
+ (write-char #\newline strm)))))
(defun date-string (ut)
(check-type ut integer)
(multiple-value-bind (sec min hr day mon year dow daylight-p zone)
(decode-universal-time ut)
(declare (ignore daylight-p zone))
- (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
- dow day (1- mon) year hr min sec)))
+ (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d"
+ dow day (1- mon) year hr min sec)))
(defun lml-quit (&optional (code 0))
"Function to exit the Lisp implementation."