--- /dev/null
+.bin
+*.fasl*
+*.fas
+*.x86f
+*.ufsl
+*.dfsl
+*.fsl
+*.cfsl
+*.x86f
+*.sparcf
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: api.lisp
+;;;; Purpose: Macros for generating API documentation
+;;;; Programmer: Kevin M. Rosenberg based on Matthew Danish's code
+;;;; Date Started: Nov 2002
+;;;;
+;;;; $Id: api.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;; and Copyright (c) 2002 Matthew Danish
+;;;;
+;;;; LML users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:lml)
+
+;;; Copyright (c) 2002 Matthew Danish.
+;;; All rights reserved.
+
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. The name of the author may not be used to endorse or promote products
+;;; derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
+;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
+;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
+;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
+;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;; For an example, see Matthew Danish's cl-ftp documentation at
+;;; http://www.mapcar.org/~mrd/cl-sql/
+
+(defmacro api-list (&body body)
+ `(ul ,@(loop for item in body collect `(li ,item))))
+
+(defun stringify (x)
+ (let ((*print-case* :downcase))
+ (if (null x)
+ "()"
+ (format nil "~A" x))))
+
+(defmacro with-class-info ((class-name superclasses &rest slot-docs) &body other-info)
+ `(p (i "Class ") (b ,(stringify class-name))
+ (i " derived from ") ,(stringify superclasses) " -- " (br)
+ (i "Initargs:") (br)
+ (ul
+ ,@(loop for (slot-name slot-desc slot-default) in slot-docs collect
+ `(li (tt ,(format nil ":~A" slot-name))
+ " -- " ,slot-desc " -- " (i "Default: ")
+ ,(if (eql slot-default :n/a)
+ "Not specified"
+ (format nil "~S" slot-default)))))
+ ,@other-info))
+
+(defmacro with-macro-info ((macro-name &rest lambda-list) &body other-info)
+ `(p (i "Macro ") (b ,(stringify macro-name)) " "
+ (tt ,(stringify lambda-list)) (br)
+ ,@other-info))
+
+(defmacro with-function-info ((function-name &rest lambda-list) &body other-info)
+ `(p (i "Function ") (b ,(stringify function-name)) " "
+ (tt ,(stringify lambda-list))
+ (br) ,@other-info))
+
+(defmacro with-condition-info ((condition-name supers &rest slot-docs) &body other-info)
+ `(p (i "Condition ") (b ,(stringify condition-name))
+ (i " derived from ") ,(stringify supers) " -- " (br)
+ (i "Slots:") (br)
+ (ul
+ ,@(loop for (slot-name slot-desc slot-reader slot-initarg slot-default) in slot-docs collect
+ `(li (tt ,(stringify slot-name))
+ " -- " ,slot-desc " -- " (i " Default: ")
+ ,(if (eql slot-default :n/a)
+ "Not specified"
+ (format nil "~S" slot-default)))))
+ ,@other-info))
+
+(defmacro with-functions (&rest slots)
+ `(progn ,@(loop for (fn description . args) in slots collect
+ `(with-function-info (,fn ,@(if args args
+ '(connection-variable)))
+ ,description))))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: base.lisp
+;;;; Purpose: Lisp Markup Language functions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: base.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:lml2)
+
+
+(defun reset-indent ()
+ (setq *indent* 0))
+
+(defun lml-format (str &rest args)
+ (when (streamp *html-stream*)
+ (when *print-spaces* (indent-spaces *indent* *html-stream*))
+ (if args
+ (apply #'format *html-stream* str args)
+ (write-string str *html-stream*))
+ (when *print-spaces* (write-char #\newline *html-stream*))))
+
+(defun lml-princ (s)
+ (princ s *html-stream*))
+
+(defun lml-print (s)
+ (format *html-stream* "~A~%" s))
+
+(defun lml-write-char (char)
+ (write-char char *html-stream*))
+
+(defun lml-write-string (str)
+ (write-string str *html-stream*))
+
+(defun lml-print-date (date)
+ (lml-write-string (date-string date)))
+
+(defmacro xhtml-prologue ()
+ `(progn
+ (lml-write-string (xml-prologue-string))
+ (lml-write-char #\newline)
+ (lml-write-string (xhtml-prologue-string))
+ (lml-write-char #\newline)))
+
+(defmacro print-page (title &body body)
+ `(html
+ (:head
+ (:title (:princ ,title)))
+ (:body ,@body)))
+
+(defmacro page (out-file &body body)
+ `(with-open-file (*html-stream*
+ (lml-file-name ,out-file :output)
+ :direction :output
+ :if-exists :supersede)
+ (xhtml-prologue)
+ (html
+ ((:html :xmlns "http://www.w3.org/1999/xhtml")
+ ,@body))))
+
+
--- /dev/null
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: data.lisp
+;;;; Purpose: Lisp Markup Language functions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: data.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:lml2)
+
+(defvar *html-stream* *standard-output*)
+
+(defvar *print-spaces* nil)
+(defvar *indent* 0)
+
+(defun html4-prologue-string ()
+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
+
+(defun xml-prologue-string ()
+ "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>")
+
+(defun xhtml-prologue-string ()
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.1//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd\">")
--- /dev/null
+.PHONY: site all clean
+
+all: site
+
+site:
+ sbcl --userinit `pwd`/make.lisp
+
+clean:
+ @rm -f *~ \#*\# .\#* memdump
+
--- /dev/null
+#+cmu (setq ext:*gc-verbose* nil)
+
+(require :lml2)
+(in-package :lml2)
+(let ((cwd (parse-namestring (lml-cwd))))
+ (process-dir cwd))
+(lml-quit)
--- /dev/null
+<?xml version="1.0" encoding="iso-8859-1" standalone="yes"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml"><head><title>LML README</title><meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" /><meta name="Copyright" content="Kevin Rosenberg 2002 <kevin@rosenberg.net>" /><meta name="description" content="Lisp Markup Language Documentation" /><meta name="author" content="Kevin Rosenberg" /><meta name="keywords" content="Common Lisp, HTML, Markup Langauge" /></head><body><h1>LML Documentation</h1><h2>Overview</h2><p><a href="http://lml.b9.com">LML</a> is a Common Lisp package for generating HTML and XHTML documents.LML is authored by <a href="mailto:kevin@rosenberg.net">Kevin Rosenberg</a>. The home page for LML is <a href="http://lml.b9.com/">http://lml.b9.com/</a>.</p><h2>Installation</h2><p>The easiest way to install LML is to use the <a href="http://www.debian.org/">Debian</a> GNU/Linux operating system. You can then use the command <tt>apt-get install cl-lml</tt> to automatically download and install the LML package.</p><p>On a non-Debian system, you need to have <a href="http://cclan.sourceforge.net/">ASDF</a> installed to load the system definition file. You will need to change the source
+ pathname in the system file to match the location where you have installed LML.</p><h2>Usage</h2><p>Currently, there is no documentation on the functions provided by LML. However, the source code is instructive and there are example files included in the LML package.</p><h2>Examples</h2><table border=1 cellpadding=3><tbody><tr><td colspan=2 style="color:#000;background-color:#ccc;font-weight:bold;">Iteration</td></tr><tr><td><pre>(html
+ (:i "The square of the first five integers are: )"
+ (:b
+ (loop as x from 1 to 5
+ doing
+ (lml-format " ~D" (* x x))))</pre></td><td><i>The square of the first five integers are: </i><b> 1 4 9 16 25</b></td></tr></tbody></table><hr /><p>View this page's <a href="http://lml.b9.com/">LML</a> <a href="readme.lml">source</a>.</p></body></html>
\ No newline at end of file
--- /dev/null
+;;; -*- Mode: Lisp -*-
+
+(in-package #:lml2)
+
+(page "readme"
+ (html
+ (:head
+ (:title "LML README")
+ ((:meta :http-equiv "Content-Type" :content "text/html; charset=iso-8859-1"))
+ ((:meta :name "Copyright" :content "Kevin Rosenberg 2002 <kevin@rosenberg.net>"))
+ ((:meta :name "description" :content "Lisp Markup Language Documentation"))
+ ((:meta :name "author" :content "Kevin Rosenberg"))
+ ((:meta :name "keywords" :content "Common Lisp, HTML, Markup Langauge")))
+
+ (:body
+ (:h1 "LML Documentation")
+ (:h2 "Overview")
+ (:p
+ ((:a :href "http://lml.b9.com") "LML")
+ " is a Common Lisp package for generating HTML and XHTML documents."
+ "LML is authored by "
+ ((:a :href "mailto:kevin@rosenberg.net") "Kevin Rosenberg")
+ ". The home page for LML is "
+ ((:a :href "http://lml.b9.com/") "http://lml.b9.com/")
+ ".")
+
+ (:h2 "Installation")
+ (:p
+ "The easiest way to install LML is to use the "
+ ((:a :href "http://www.debian.org/") "Debian")
+ " GNU/Linux operating system. You can then use the command "
+ (:tt "apt-get install cl-lml")
+ " to automatically download and install the LML package.")
+ (:p
+ "On a non-Debian system, you need to have "
+ ((:a :href "http://cclan.sourceforge.net/") "ASDF")
+ " installed to load the system definition file. You will need to change the source
+ pathname in the system file to match the location where you have installed LML.")
+
+ (:h2 "Usage")
+ (:p
+ "Currently, there is no documentation on the functions provided by LML. However, the source code is instructive and there are example files included in the LML package.")
+
+ (:h2 "Examples")
+ ((:table :border 1 :cellpadding 3)
+ (:tbody
+ (:tr
+ ((:td :colspan 2 :style "color:#000;background-color:#ccc;font-weight:bold;")
+ "Iteration"))
+ (:tr
+ (:td
+ (:pre
+"(html
+ (:i \"The square of the first five integers are: )\"
+ (:b
+ (loop as x from 1 to 5
+ doing
+ (lml-format \" ~D\" (* x x))))"))
+ (:td
+ (:i "The square of the first five integers are: ")
+ (:b
+ (loop as x from 1 to 5
+ doing
+ (lml-format " ~D" (* x x))))))
+ ))
+ :hr
+ (:p
+ "View this page's "
+ ((:a :href "http://lml.b9.com/") "LML")
+ " "
+ ((:a :href "readme.lml") "source")
+ ".")
+ )))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: downloads.lisp
+;;;; Purpose: Generate downloads page
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: downloads.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:lml2)
+
+
+(defvar *dl-base*)
+(defvar *dl-url*)
+(defvar *base-name*)
+(defvar *section-indent* 0)
+(defvar *signed* nil)
+
+(defun list-files (files)
+ "List files in a directory for downloading"
+ ;;files.sort()
+ (mapcar #'print-file files))
+
+(defun strip-dl-base (file)
+ (let ((fdir (pathname-directory file))
+ (bdir (pathname-directory *dl-base*)))
+ (make-pathname
+ :name (pathname-name file)
+ :type (pathname-type file)
+ :directory
+ (when (> (length fdir) (length bdir))
+ (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")))
+ (when (plusp (length basename))
+ (with-open-file (strm file :direction :input)
+ (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))
+ (html :br))))
+
+(defun display-header (name url)
+ (lml-princ "<h1>Download</h1>")
+ (lml-princ "<div class=\"mainbody\">")
+ (lml-format "<h3>Browse ~A Download Site</h3>" name)
+ (lml-format "<a style=\"padding-left:20pt;\" href=\"~A\">~A</a>" url url))
+
+(defun display-footer ()
+ (when *signed*
+ (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? (name)
+ (let ((len-base-name (length *base-name*)))
+ (when (>= (length name) len-base-name)
+ (string= name *base-name* :end1 len-base-name :end2 len-base-name))))
+
+(defun match-base-name-latest? (name)
+ (let* ((latest (concatenate 'string *base-name* "-latest"))
+ (len-latest (length latest)))
+ (when (>= (length name) len-latest)
+ (string= name latest :end1 len-latest :end2 len-latest))))
+
+(defun filter-against-base (files)
+ (delete-if-not #'(lambda (f) (match-base-name? (pathname-name f))) files))
+
+(defun filter-latest (files)
+ (delete-if #'(lambda (f) (match-base-name-latest? (pathname-name f))) files))
+
+(defun sort-pathnames (list)
+ (sort list #'(lambda (a b) (string< (namestring a) (namestring b)))))
+
+(defun display-one-section (title pat)
+ (let ((files (sort-pathnames (filter-latest
+ (filter-against-base (directory pat))))))
+ (when files
+ (print-sect-title title)
+ (lml-princ "<div style=\"padding-left: 20pt;\">")
+ (list-files files)
+ (lml-princ "</div>"))))
+
+(defun display-sections (sects)
+ (when sects
+ (let ((title (car 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))))))
+
+(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))
+ (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)))
+ (display-page pkg-name pkg-base dl-base dl-url
+ `(("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)))
+ (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))))))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: files.cl
+;;;; Purpose: File and directory functions for LML
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:lml2)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *output-dir* nil)
+ (defvar *sources-dir* nil)
+ )
+
+(defmacro lml-file-name (file &optional (type :source))
+ (let ((f file))
+ (when (and (consp f) (eql (car f) 'cl:quote))
+ (setq f (cadr f)))
+ (when (symbolp f)
+ (setq f (string-downcase (symbol-name f))))
+ (when (stringp f)
+ (unless (position #\. f)
+ (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))
+ (if (stringp f)
+ (parse-namestring f)
+ f))))
+
+(defmacro with-dir ((output &key sources) &body body)
+ (let ((output-dir (gensym))
+ (sources-dir (gensym)))
+ `(let ((,output-dir ,output)
+ (,sources-dir ,sources))
+ (when (stringp ,output-dir)
+ (setq ,output-dir (parse-namestring ,output-dir)))
+ (when (stringp ,sources-dir)
+ (setq ,sources-dir (parse-namestring ,sources-dir)))
+ (unless ,sources-dir
+ (setq ,sources-dir ,output-dir))
+ (let ((*output-dir* ,output-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)))
+ (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"))))
+ (dolist (file lml-files)
+ (format *trace-output* "~&; Processing ~A~%" file)
+ (lml-load-path file)))))
+
+(defun lml-load (file)
+ (lml-load-path (eval `(lml-file-name ,file :source))))
+
+(defun include-file (file)
+ (print-file-contents file *html-stream*))
--- /dev/null
+;; -*- mode: common-lisp; package: lml2 -*-
+;;
+;; $Id: htmlgen.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;
+;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
+;; copyright (c) 2003 Kevin Rosenberg
+;;
+;; Main changes from Allegro version:
+;; - Support XHTML
+;; - lowercase symbol names
+;;
+;; 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 Free Software Foundation, as clarified by the AllegroServe
+;; prequel found in license-allegroserve.txt.
+
+
+(in-package #:lml2)
+
+
+;; html generation
+
+(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
+ special ; if true then call this to process the keyword and return
+ ; the macroexpansion
+ print ; function used to handle this in html-print
+ name-attr ; attribute symbols which can name this object for subst purposes
+ )
+
+
+(defparameter *html-process-table*
+ (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes
+ )
+
+(defmacro html (&rest forms &environment env)
+ ;; just emit html to the current stream
+ (process-html-forms forms env))
+
+(defmacro html-out-stream-check (stream)
+ ;; ensure that a real stream is passed to this function
+ `(let ((.str. ,stream))
+ (if* (not (streamp .str.))
+ then (error "html-stream must be passed a stream object, not ~s"
+ .str.))
+ .str.))
+
+
+(defmacro html-stream (stream &rest forms)
+ ;; set output stream and emit html
+ `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms)))
+
+
+(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)
+ (if* (setq spec (html-process-special ent))
+ then ; do something different
+ (push (funcall spec ent args argsp body) res)
+ elseif (null argsp)
+ then ; singleton tag, just do the set
+ (push `(,(html-process-macro ent) :set) res)
+ nil
+ else (if* (equal args '(:unset))
+ then ; ((:tag :unset)) is a special case.
+ ; that allows us to close off singleton tags
+ ; printed earlier.
+ (push `(,(html-process-macro ent) :unset) res)
+ nil
+ else ; 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)
+ then (if* (keywordp form)
+ then (let ((ent (gethash form *html-process-table*)))
+ (if* (null ent)
+ then (error "unknown html keyword ~s"
+ form)
+ else (do-ent ent nil nil nil)))
+ elseif (stringp form)
+ then ; turn into a print of it
+ (push `(write-string ,form *html-stream*) res)
+ else (push form res))
+ else (let ((first (car form)))
+ (if* (keywordp first)
+ then ; (:xxx . body) form
+ (let ((ent (gethash first
+ *html-process-table*)))
+ (if* (null ent)
+ then (error "unknown html keyword ~s"
+ form)
+ else (do-ent ent nil t (cdr form))))
+ elseif (and (consp first) (keywordp (car first)))
+ then ; ((:xxx args ) . body)
+ (let ((ent (gethash (car first)
+ *html-process-table*)))
+ (if* (null ent)
+ then (error "unknown html keyword ~s"
+ form)
+ else (do-ent ent (cdr first) t (cdr form))))
+ else (push form res))))))
+ `(progn ,@(nreverse res))))
+
+
+(defun html-atom-check (args open close body)
+ (if* (and args (atom args))
+ then (let ((ans (case args
+ (:set `(write-string ,open *html-stream*))
+ (:unset `(write-string ,close *html-stream*))
+ (t (error "illegal arg ~s to ~s" args open)))))
+ (if* (and ans body)
+ then (error "can't have a body form with this arg: ~s"
+ args)
+ else ans))))
+
+(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*)))
+
+
+(defun html-body-key-form (string-code has-inv args body)
+ ;; do what's needed to handle given keywords in the args
+ ;; then do the body
+ (if* (and args (atom args))
+ then ; single arg
+ (return-from html-body-key-form
+ (case args
+ (:set (if* has-inv
+ then `(write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ else `(write-string ,(format nil "<~a />" string-code)
+ *html-stream*)))
+ (:unset (if* has-inv
+ then `(write-string ,(format nil "</~a>" string-code)
+ *html-stream*)))
+ (t (error "illegal arg ~s to ~s" args string-code)))))
+
+ (if* (not (evenp (length args)))
+ then (warn "arg list ~s isn't even" args))
+
+
+ (if* args
+ then `(progn (write-string ,(format nil "<~a" string-code)
+ *html-stream*)
+ ,@(do ((xx args (cddr xx))
+ (res))
+ ((null xx)
+ (nreverse res))
+ (if* (eq :if* (car xx))
+ then ; insert following conditionally
+ (push `(if* ,(cadr xx)
+ then (write-string
+ ,(format nil " ~(~a~)" (caddr xx))
+ *html-stream*)
+ (prin1-safe-http-string ,(cadddr xx)))
+ res)
+ (pop xx) (pop xx)
+ else
+
+ (push `(write-string
+ ,(format nil " ~(~a~)" (car xx))
+ *html-stream*)
+ res)
+ (push `(prin1-safe-http-string ,(cadr xx)) res)))
+
+ ,(unless has-inv `(write-string " /" *html-stream*))
+ (write-string ">" *html-stream*)
+ ,@body
+ ,(if* (and body has-inv)
+ then `(write-string ,(format nil "</~a>" string-code)
+ *html-stream*)))
+ else
+ (if* has-inv
+ then
+ `(progn (write-string ,(format nil "<~a>" string-code)
+ *html-stream*)
+ ,@body
+ ,(if* body
+ then `(write-string ,(format nil "</~a>" string-code)
+ *html-stream*)))
+ else
+ `(progn (write-string ,(format nil "<~a />" string-code)
+ *html-stream*)))))
+
+
+
+(defun princ-http (val)
+ ;; print the given value to the http stream using ~a
+ (format *html-stream* "~a" val))
+
+(defun prin1-http (val)
+ ;; print the given value to the http stream using ~s
+ (format *html-stream* "~s" val))
+
+
+(defun princ-safe-http (val)
+ (emit-safe *html-stream* (format nil "~a" val)))
+
+(defun prin1-safe-http (val)
+ (emit-safe *html-stream* (format nil "~s" val)))
+
+
+(defun prin1-safe-http-string (val)
+ ;; used only in a parameter value situation
+ ;;
+ ;; if the parameter value is the symbol with the empty print name
+ ;; then turn this into a singleton object. Thus || is differnent
+ ;; than "".
+ ;;
+ ;; print the contents inside a string double quotes (which should
+ ;; not be turned into "'s
+ ;; symbols are turned into their name
+ (if* (and (symbolp val)
+ (equal "" (symbol-name val)))
+ thenret ; do nothing
+ else (write-char #\= *html-stream*)
+ (if* (or (stringp val)
+ (and (symbolp val)
+ (setq val (string-downcase
+ (symbol-name val)))))
+ then (write-char #\" *html-stream*)
+ (emit-safe *html-stream* val)
+ (write-char #\" *html-stream*)
+ else (prin1-safe-http val))))
+
+
+
+(defun emit-safe (stream string)
+ ;; 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)))
+ ((>= i end)
+ (if* (< start i)
+ then (write-sequence string
+ stream
+ :start start
+ :end i)))
+
+
+ (let ((ch (schar string i))
+ (cvt ))
+ (if* (eql ch #\<)
+ then (setq cvt "<")
+ elseif (eq ch #\>)
+ then (setq cvt ">")
+ elseif (eq ch #\&)
+ then (setq cvt "&")
+ elseif (eq ch #\")
+ then (setq cvt """))
+ (if* cvt
+ then ; must do a conversion, emit previous chars first
+
+ (if* (< start i)
+ then (write-sequence string
+ stream
+ :start start
+ :end i))
+ (write-string cvt stream)
+
+ (setq start (1+ i))))))
+
+
+
+(defun html-print-list (list-of-forms stream &key unknown)
+ ;; html print a list of forms
+ (dolist (x list-of-forms)
+ (html-print-subst x nil stream unknown)))
+
+
+(defun html-print-list-subst (list-of-forms subst stream &key unknown)
+ ;; html print a list of forms
+ (dolist (x list-of-forms)
+ (html-print-subst x subst stream unknown)))
+
+
+(defun html-print (form stream &key unknown)
+ (html-print-subst form nil stream unknown))
+
+
+(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 (if* (atom form)
+ then form
+ elseif (consp (car form))
+ then (setq attrs (cdar form))
+ (caar form)
+ else (car form)))
+ print-handler
+ ent)
+ (if* (keywordp possible-kwd)
+ then (if* (null (setq ent (gethash possible-kwd *html-process-table*)))
+ then (if* unknown
+ then (return-from html-print-subst
+ (funcall unknown form stream))
+ else (error "unknown html tag: ~s" possible-kwd))
+ else ; see if we should subst
+ (if* (and subst
+ attrs
+ (setq attr-name (html-process-name-attr ent))
+ (setq name (getf attrs attr-name))
+ (setq attrs (html-find-value name subst)))
+ then
+ (return-from html-print-subst
+ (if* (functionp (cdr attrs))
+ then
+ (funcall (cdr attrs) stream)
+ else (html-print-subst
+ (cdr attrs)
+ subst
+ stream
+ unknown)))))
+
+ (setq print-handler
+ (html-process-print ent)))
+ (if* (atom form)
+ then (if* (keywordp form)
+ then (funcall print-handler ent :set nil nil nil nil stream)
+ elseif (stringp form)
+ then (write-string form stream)
+ else (princ form stream))
+ elseif ent
+ then (funcall print-handler
+ ent
+ :full
+ (if* (consp (car form)) then (cdr (car form)))
+ form
+ subst
+ unknown
+ stream)
+ else (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))
+ (loop
+ (do* ((entlist alist (cdr entlist))
+ (ent (car entlist) (car entlist)))
+ ((null entlist) (setq alist nil))
+ (if* (consp (car ent))
+ then ; this is another alist
+ (if* (cdr entlist)
+ then (push (cdr entlist) to-process))
+ (setq alist ent)
+ (return) ; exit do*
+ elseif (equal key (car ent))
+ then (return-from html-find-value ent)))
+
+ (if* (null alist)
+ then ; we need to find a new alist to process
+
+ (if* to-process
+ then (setq alist (pop to-process))
+ else (return))))))
+
+(defun html-standard-print (ent cmd args form subst unknown stream)
+ ;; the print handler for the normal html operators
+ (ecase cmd
+ (:set ; just turn it on
+ (format stream "<~a>" (html-process-key ent)))
+ (:full ; set, do body and then unset
+ (let (iter)
+ (if* args
+ then (if* (and (setq iter (getf args :iter))
+ (setq iter (html-find-value iter subst)))
+ then ; 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)
+ else
+ (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 ">"))
+ else (format stream "<~a>" (html-process-key ent)))
+ (dolist (ff (cdr form))
+ (html-print-subst ff subst stream unknown)))
+ (if* (html-process-has-inverse ent)
+ then ; end the form
+ (format stream "</~a>" (html-process-key ent))))))
+
+
+
+
+
+
+
+
+;; -- defining how html tags are handled. --
+;;
+;; most tags are handled in a standard way and the def-std-html
+;; macro is used to define such tags
+;;
+;; Some tags need special treatment and def-special-html defines
+;; 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
+;; (: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*)
+ (make-html-process ,kwd nil nil ,fcn ,print-fcn nil)))
+
+
+(defmacro named-function (name &body body)
+ (declare (ignore name))
+ `(function ,@body))
+
+
+(def-special-html :newline
+ (named-function html-newline-function
+ (lambda (ent args argsp body)
+ (declare (ignore ent args argsp))
+ (if* body
+ then (error "can't have a body with :newline -- body is ~s" body))
+
+ `(terpri *html-stream*)))
+
+ (named-function html-newline-print-function
+ (lambda (ent cmd args form subst unknown stream)
+ (declare (ignore args ent unknown subst))
+ (if* (eq cmd :set)
+ then (terpri stream)
+ else (error ":newline in an illegal place: ~s" form)))))
+
+(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))))
+
+ (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)
+ then (format stream "~a" (cadr form))
+ else (error ":princ must be given an argument")))))
+
+(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))))
+ (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)
+ then (emit-safe stream (format nil "~a" (cadr form)))
+ else (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))))
+ (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)
+ then (format stream "~s" (cadr form))
+ else (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))))
+ (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)
+ then (emit-safe stream (format nil "~s" (cadr form)))
+ else (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*))))
+ (named-function html-comment-print-function
+ (lambda (ent cmd args form subst unknown stream)
+ (declare (ignore ent cmd args subst unknown))
+ (format stream "<!--~a-->" (cadr form)))))
+
+
+
+(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))))
+ `(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)))))
+
+
+
+(def-std-html :a t nil)
+(def-std-html :abbr t nil)
+(def-std-html :acronym t nil)
+(def-std-html :address t nil)
+(def-std-html :applet t nil)
+(def-std-html :area nil nil)
+
+(def-std-html :b t nil)
+(def-std-html :base nil nil)
+(def-std-html :basefont nil nil)
+(def-std-html :bdo t nil)
+(def-std-html :bgsound nil nil)
+(def-std-html :big t nil)
+(def-std-html :blink t nil)
+(def-std-html :blockquote t nil)
+(def-std-html :body t nil)
+(def-std-html :br nil nil)
+(def-std-html :button nil nil)
+
+(def-std-html :caption t nil)
+(def-std-html :center t nil)
+(def-std-html :cite t nil)
+(def-std-html :code t nil)
+(def-std-html :col nil nil)
+(def-std-html :colgroup nil nil)
+
+(def-std-html :dd t nil)
+(def-std-html :del t nil)
+(def-std-html :dfn t nil)
+(def-std-html :dir t nil)
+(def-std-html :div t nil)
+(def-std-html :dl t nil)
+(def-std-html :dt t nil)
+
+(def-std-html :em t nil)
+(def-std-html :embed t nil)
+
+(def-std-html :fieldset t nil)
+(def-std-html :font t nil)
+(def-std-html :form t :name)
+(def-std-html :frame t nil)
+(def-std-html :frameset t nil)
+
+(def-std-html :h1 t nil)
+(def-std-html :h2 t nil)
+(def-std-html :h3 t nil)
+(def-std-html :h4 t nil)
+(def-std-html :h5 t nil)
+(def-std-html :h6 t nil)
+(def-std-html :head t nil)
+(def-std-html :hr nil nil)
+(def-std-html :html t nil)
+
+(def-std-html :i t nil)
+(def-std-html :iframe t nil)
+(def-std-html :ilayer t nil)
+(def-std-html :img nil :id)
+(def-std-html :input nil 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 :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 :marquee t 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 :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 :optgroup t nil)
+(def-std-html :option 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 :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 :u t nil)
+(def-std-html :ul t nil)
+
+(def-std-html :var t nil)
+
+(def-std-html :wbr nil nil)
+
+(def-std-html :xmp t nil)
+
+
+
+
+;;; KMR Local Additions
+
+(def-special-html :jscript
+ (named-function html-comment-function
+ (lambda (ent args argsp body)
+ ;; must use <!-- --> syntax
+ (declare (ignore ent args argsp))
+ `(progn (write-string "<script language=\"JavasSript\" type=\"text/javascript\">"
+ *html-stream*)
+ (html ,@body)
+ (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\">~A</script>"
+ (cadr form)))))
--- /dev/null
+;;; -*- mode: common-lisp; package: lml2 -*-
+;;;
+;;; $Id: ifstar.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;
+;;; Public domain code by Franz
+
+(in-package #:lml2)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar if*-keyword-list '("then" "thenret" "else" "elseif")))
+
+(defmacro if* (&rest args)
+ (do ((xx (reverse args) (cdr xx))
+ (state :init)
+ (elseseen nil)
+ (totalcol nil)
+ (lookat nil nil)
+ (col nil))
+ ((null xx)
+ (cond ((eq state :compl)
+ `(cond ,@totalcol))
+ (t (error "if*: illegal form ~s" args))))
+ (cond ((and (symbolp (car xx))
+ (member (symbol-name (car xx))
+ if*-keyword-list
+ :test #'string-equal))
+ (setq lookat (symbol-name (car xx)))))
+
+ (cond ((eq state :init)
+ (cond (lookat (cond ((string-equal lookat "thenret")
+ (setq col nil
+ state :then))
+ (t (error
+ "if*: bad keyword ~a" lookat))))
+ (t (setq state :col
+ col nil)
+ (push (car xx) col))))
+ ((eq state :col)
+ (cond (lookat
+ (cond ((string-equal lookat "else")
+ (cond (elseseen
+ (error
+ "if*: multiples elses")))
+ (setq elseseen t)
+ (setq state :init)
+ (push `(t ,@col) totalcol))
+ ((string-equal lookat "then")
+ (setq state :then))
+ (t (error "if*: bad keyword ~s"
+ lookat))))
+ (t (push (car xx) col))))
+ ((eq state :then)
+ (cond (lookat
+ (error
+ "if*: keyword ~s at the wrong place " (car xx)))
+ (t (setq state :compl)
+ (push `(,(car xx) ,@col) totalcol))))
+ ((eq state :compl)
+ (cond ((not (string-equal lookat "elseif"))
+ (error "if*: missing elseif clause ")))
+ (setq state :init)))))
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: lml2-tests.asd
+;;;; Purpose: ASDF system definitionf for lml2 testing package
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: Apr 2003
+;;;;
+;;;; $Id: lml2-tests.asd,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;; *************************************************************************
+
+(defpackage #:lml2-tests-system
+ (:use #:asdf #:cl))
+(in-package #:lml2-tests-system)
+
+(defsystem lml2-tests
+ :depends-on (:rt :lml2)
+ :components
+ ((:file "tests")))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'lml2-tests))))
+ (or (funcall (intern (symbol-name '#:do-tests)
+ (find-package '#:regression-test)))
+ (error "test-op failed")))
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: lml2.asd
+;;;; Purpose: ASDF definition file for Lisp Markup Language Version 2
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: lml2.asd,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+(defpackage #:lml2-system (:use #:asdf #:cl))
+(in-package #:lml2-system)
+
+(defsystem lml2
+ :name "lml2"
+ :author "Kevin M. Rosenberg <kevin@rosenberg.net>"
+ :version "1.0"
+ :maintainer "Kevin M. Rosenberg <kmr@debian.org>"
+ :licence "GNU General Public License"
+ :description "Lisp Markup Language"
+ :long-description "LML2 provides creation of XHTML for Lisp programs."
+
+ :components
+ ((:file "package")
+ (:file "ifstar" :depends-on ("package"))
+ (:file "data" :depends-on ("package"))
+ (:file "htmlgen" :depends-on ("ifstar" "data"))
+ (:file "utils" :depends-on ("package"))
+ (:file "files" :depends-on ("utils" "htmlgen"))
+ (:file "base" :depends-on ("files"))
+ (:file "read-macro" :depends-on ("base"))
+ (:file "stdsite" :depends-on ("base"))
+ (:file "downloads" :depends-on ("base"))
+ ))
+
+(defmethod perform ((o test-op) (c (eql (find-system 'lml2))))
+ (operate 'load-op 'lml2-tests)
+ (operate 'test-op 'lml2-tests))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.lisp
+;;;; Purpose: Package file for Lisp Markup Language 2
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: June 2003
+;;;;
+;;;; $Id: package.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:cl-user)
+
+(defpackage #:lisp-markup-language-2
+ (:use #:common-lisp)
+ (:nicknames #:lml2)
+ (:export
+
+ ;; base.lisp
+ #:*print-spaces*
+ #:reset-indent
+ #:with
+ #:print-page
+ #:page
+ #:lml-format
+ #:lml-print
+ #:lml-princ
+ #:lml-write-char
+ #:lml-write-string
+ #:lml-print-date
+ #:*html-output*
+
+ ;; htmlgen.lisp
+ #:html #:html-print #:html-print-subst #:html-print-list #:html-print-list-subst
+ #:html-stream #:*html-stream*
+
+
+ ;; files.lisp
+ #:with-dir
+ #:process-dir
+ #:lml-load
+ #:include-file
+
+ ;; stdsite.lisp
+ #:print-std-page
+ #:std-page
+ #:std-body
+ #:std-head
+ #:titled-pre-section
+
+ ;; downloads.lisp
+ #:std-dl-page
+ #:full-dl-page
+
+ ;; utils.lisp
+ #:lml-quit
+ #:lml-cwd
+))
--- /dev/null
+;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: read-macro.lisp
+;;;; Purpose: Lisp Markup Language functions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: read-macro.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+(in-package #:lml2)
+
+(defun new-string ()
+ (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
+
+(set-macro-character #\[
+ #'(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)))))
+
+ #+cmu
+ (setf curr-string (coerce curr-string `(simple-array character (*))))
+
+ (push `(lml2-princ ,curr-string) forms)
+ `(progn ,@(nreverse forms)))))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: stdsite.lisp
+;;;; Purpose: Functions to create my standard style sites
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: stdsite.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
+;;;;
+;;;; LML2 users are granted the rights to distribute and use this software
+;;;; as governed by the terms of the GNU General Public License v2
+;;;; (http://www.gnu.org/licenses/gpl.html)
+;;;; *************************************************************************
+
+;;; A "standard site" is a format for a certain style of web page.
+;;; It is based on the LML2 package.
+;;; A stdsite page expects to include the following files:
+;;; head.lml_
+;;; banner.lml_
+;;; content.lml_
+;;; footer.lml_
+
+(in-package #:lml2)
+
+(defmacro std-head (title &body body)
+ `(html
+ (:head
+ (:title (:princ ,title))
+ (lml-load "head.lml_")
+ ,@body)))
+
+
+(defun std-footer (file)
+ (html
+ ((:div :class "disclaimsec")
+ (let ((src-file (make-pathname
+ :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)))))))
+ (when (probe-file "footer.lml_")
+ (lml-load "footer.lml_")))))
+
+
+(defmacro std-body (file &body body)
+ `(body
+ (lml-load "banner.lml_")
+ (html
+ ((:table :class "stdbodytable" :border "0" :cellpadding "3")
+ (:tbody
+ ((:tr :valign "top")
+ ((td :class "stdcontentcell")
+ (lml-load "contents.lml_"))
+ ((:td :valign "top")
+ ,@body
+ (std-footer ,file))))))))
+
+
+(defmacro print-std-page (file title &body body)
+ `(progn
+ (xhtml-prologue)
+ (html
+ ((:html :xmlns "http://www.w3.org/1999/xhtml")
+ (std-head ,title)
+ (std-body ,file ,@body)))))
+
+(defmacro std-page (out-file title &body body)
+ `(let ((*indent* 0))
+ (with-open-file (*html-stream* (lml-file-name ,out-file :output)
+ :direction :output
+ :if-exists :supersede)
+ (print-std-page (lml-file-name ,out-file :source) ,title ,@body))))
+
+(defmacro titled-pre-section (title &body body)
+ `(progn
+ (html
+ (:h1 ,title)
+ ((:pre "style" "padding-left:30pt;")
+ ,@body))))
+
+
+
--- /dev/null
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: lml-tests.lisp
+;;;; Purpose: lml tests file
+;;;; Author: Kevin M. Rosenberg
+;;;; Date Started: Apr 2003
+;;;;
+;;;; $Id: tests.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg
+;;;;
+;;;; *************************************************************************
+
+(in-package #:cl)
+(defpackage #:lml-tests
+ (:use #:lml #:cl #:rtest))
+(in-package #:lml-tests)
+
+(rem-all-tests)
+
+(deftest lml.0
+ (with-output-to-string (s)
+ (let ((*html-output* s))
+ (div)))
+ "<div></div>")
+
+(deftest lml.1
+ (with-output-to-string (s)
+ (let ((*html-output* s))
+ (span-c foo "Foo Bar")))
+ "<span class=\"foo\">Foo Bar</span>")
+
+(deftest lml.2
+ (with-output-to-string (s)
+ (let ((*html-output* s))
+ (table-c foo :style "width:80%" "Foo" " Bar" " test")))
+ "<table class=\"foo\" style=\"width:80%\">Foo Bar test</table>")
+
+(deftest lml.3
+ (with-output-to-string (s)
+ (let ((*html-output* s)
+ (a 5.5d0))
+ (p a)))
+ "<p>5.5d0</p>")
+
+(deftest lml.4
+ (with-output-to-string (s)
+ (let ((*html-output* s)
+ (a 0.75))
+ (img "http://localhost/test.png" :width a)))
+ "<img src=\"http://localhost/test.png\" width=\"0.75\" />")
+
+(deftest lml.5
+ (with-output-to-string (s)
+ (let ((*html-output* s))
+ (div "Start"
+ (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"))))
+ "<div style=\"font-weight:bold\">Start<p class=\"a_class\">Testing</p></div>")
+
--- /dev/null
+;;; $Id: utils.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $
+;;;;
+;;;; General purpose utilities
+
+(in-package #:lml2)
+
+(defmacro aif (test then &optional else)
+ `(let ((it ,test))
+ (if it ,then ,else)))
+
+(defmacro awhen (test-form &body body)
+ `(aif ,test-form
+ (progn ,@body)))
+
+(defun keyword-symbol? (x)
+ "Returns T if object is a symbol in the keyword package"
+ (and (symbolp x)
+ (string-equal "keyword" (package-name (symbol-package x)))))
+
+(defun list-to-spaced-string (list)
+ (format nil "~{~A~^ ~}" list))
+
+(defun print-n-chars (char n stream)
+ (declare (fixnum n)
+ (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))
+
+(defun print-file-contents (file &optional (strm *standard-output*))
+ "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)))))
+
+(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)))
+
+(defun lml-quit (&optional (code 0))
+ "Function to exit the Lisp implementation."
+ #+allegro (excl:exit code)
+ #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code)
+ #+(or cmu scl) (ext:quit code)
+ #+cormanlisp (win32:exitprocess code)
+ #+gcl (lisp:bye code)
+ #+lispworks (lw:quit :status code)
+ #+lucid (lcl:quit code)
+ #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
+ #+openmcl (ccl:quit code)
+ #+(and mcl (not openmcl)) (declare (ignore code))
+ #+(and mcl (not openmcl)) (ccl:quit)
+ #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl)
+ (error 'not-implemented :proc (list 'quit code)))
+
+
+(defun lml-cwd ()
+ "Returns the current working directory. Based on CLOCC's DEFAULT-DIRECTORY function."
+ #+allegro (excl:current-directory)
+ #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory)
+ #+(or cmu scl) (ext:default-directory)
+ #+cormanlisp (ccl:get-current-directory)
+ #+lispworks (hcl:get-working-directory)
+ #+lucid (lcl:working-directory)
+ #+sbcl (sb-unix:posix-getcwd/)
+ #+mcl (ccl:mac-default-directory)
+ #-(or allegro clisp cmu scl sbcl cormanlisp lispworks lucid mcl) (truename "."))
+
+
projects / lml.git / commitdiff