--- /dev/null
+lml (1.0.0-1) unstable; urgency=low
+
+ * Initial Release.
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Sun, 15 Sep 2002 17:00:47 -0600
+
--- /dev/null
+Source: lml
+Section: devel
+Priority: optional
+Maintainer: Kevin M. Rosenberg <kmr@debian.org>
+Build-Depends: debhelper (>> 4.0.0)
+Standards-Version: 3.5.7.0
+
+Package: lml
+Architecture: any
+Depends: ${shlibs:Depends}
+Description: Lisp Markup Language
+ LML provides a markup language for generation XHTML web pages.
+
--- /dev/null
+Debian Copyright Section
+========================
+
+Upstream Source URL: ftp://lml.med-info.com
+Upstream Author: Kevin M. Rosenberg <kmr@debian.org>
+Debian Maintainer: (Same as upstream)
+
+Since the upstream author is the same as the Debian maintainer,
+there should be no divergence between the upstream package and
+the Debian package.
+
+
+Upstream Copyright Statement
+============================
+LML is written and Copyright (c) 2002 by Kevin M. Rosenberg.
+
+LML is licensed under the terms of the Lisp Lesser GNU Public
+License, known as the LLGPL. The LLGPL consists of a preamble (see
+below) and the Lessor GNU Public License 2.1 (LGPL-2.1). Where these
+conflict, the preamble takes precedence. CLSQL is referenced in the
+preamble as the "LIBRARY." The LGPL-2.1 is stored on a Debian system
+in the file /usr/share/common-licenses/LGPL-2.1.
+
+LML is distributed in the hope that it will be useful, but WITHOUT
+ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE.
+
+
+
+Preamble to the Gnu Lesser General Public License
+-------------------------------------------------
+Copyright (c) 2000 Franz Incorporated, Berkeley, CA 94704
+
+The concept of the GNU Lesser General Public License version 2.1
+("LGPL") has been adopted to govern the use and distribution of
+above-mentioned application. However, the LGPL uses terminology that
+is more appropriate for a program written in C than one written in
+Lisp. Nevertheless, the LGPL can still be applied to a Lisp program if
+certain clarifications are made. This document details those
+clarifications. Accordingly, the license for the open-source Lisp
+applications consists of this document plus the LGPL. Wherever there
+is a conflict between this document and the LGPL, this document takes
+precedence over the LGPL.
+
+A "Library" in Lisp is a collection of Lisp functions, data and
+foreign modules. The form of the Library can be Lisp source code (for
+processing by an interpreter) or object code (usually the result of
+compilation of source code or built with some other
+mechanisms). Foreign modules are object code in a form that can be
+linked into a Lisp executable. When we speak of functions we do so in
+the most general way to include, in addition, methods and unnamed
+functions. Lisp "data" is also a general term that includes the data
+structures resulting from defining Lisp classes. A Lisp application
+may include the same set of Lisp objects as does a Library, but this
+does not mean that the application is necessarily a "work based on the
+Library" it contains.
+
+The Library consists of everything in the distribution file set before
+any modifications are made to the files. If any of the functions or
+classes in the Library are redefined in other files, then those
+redefinitions ARE considered a work based on the Library. If
+additional methods are added to generic functions in the Library,
+those additional methods are NOT considered a work based on the
+Library. If Library classes are subclassed, these subclasses are NOT
+considered a work based on the Library. If the Library is modified to
+explicitly call other functions that are neither part of Lisp itself
+nor an available add-on module to Lisp, then the functions called by
+the modified Library ARE considered a work based on the Library. The
+goal is to ensure that the Library will compile and run without
+getting undefined function errors.
+
+It is permitted to add proprietary source code to the Library, but it
+must be done in a way such that the Library will still run without
+that proprietary code present. Section 5 of the LGPL distinguishes
+between the case of a library being dynamically linked at runtime and
+one being statically linked at build time. Section 5 of the LGPL
+states that the former results in an executable that is a "work that
+uses the Library." Section 5 of the LGPL states that the latter
+results in one that is a "derivative of the Library", which is
+therefore covered by the LGPL. Since Lisp only offers one choice,
+which is to link the Library into an executable at build time, we
+declare that, for the purpose applying the LGPL to the Library, an
+executable that results from linking a "work that uses the Library"
+with the Library is considered a "work that uses the Library" and is
+therefore NOT covered by the LGPL.
+
+Because of this declaration, section 6 of LGPL is not applicable to
+the Library. However, in connection with each distribution of this
+executable, you must also deliver, in accordance with the terms and
+conditions of the LGPL, the source code of Library (or your derivative
+thereof) that is incorporated into this executable.
+
--- /dev/null
+#! /bin/sh
+# postinst script for lml
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=lml
+
+# summary of how this script can be called:
+# * <postinst> `configure' <most-recently-configured-version>
+# * <old-postinst> `abort-upgrade' <new version>
+# * <conflictor's-postinst> `abort-remove' `in-favour' <package>
+# <new-version>
+# * <deconfigured's-postinst> `abort-deconfigure' `in-favour'
+# <failed-install-package> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+#
+# quoting from the policy:
+# Any necessary prompting should almost always be confined to the
+# post-installation script, and should be protected with a conditional
+# so that unnecessary prompting doesn't happen if a package's
+# installation fails and the `postinst' is called with `abort-upgrade',
+# `abort-remove' or `abort-deconfigure'.
+
+case "$1" in
+ configure)
+ /usr/sbin/register-common-lisp-source ${LISP_PKG}
+
+ ;;
+
+ abort-upgrade|abort-remove|abort-deconfigure)
+
+ ;;
+
+ *)
+ echo "postinst called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+#! /bin/sh
+# prerm script for lml
+#
+# see: dh_installdeb(1)
+
+set -e
+
+# package name according to lisp
+LISP_PKG=lml
+
+# summary of how this script can be called:
+# * <prerm> `remove'
+# * <old-prerm> `upgrade' <new-version>
+# * <new-prerm> `failed-upgrade' <old-version>
+# * <conflictor's-prerm> `remove' `in-favour' <package> <new-version>
+# * <deconfigured's-prerm> `deconfigure' `in-favour'
+# <package-being-installed> <version> `removing'
+# <conflicting-package> <version>
+# for details, see http://www.debian.org/doc/debian-policy/ or
+# the debian-policy package
+
+
+case "$1" in
+ remove|upgrade|deconfigure)
+ /usr/sbin/unregister-common-lisp-source ${LISP_PKG}
+ ;;
+ failed-upgrade)
+ ;;
+ *)
+ echo "prerm called with unknown argument \`$1'" >&2
+ exit 1
+ ;;
+esac
+
+# dh_installdeb will replace this with shell code automatically
+# generated by other debhelper scripts.
+
+#DEBHELPER#
+
+exit 0
+
+
--- /dev/null
+#!/usr/bin/make -f
+
+export DH_COMPAT=4
+
+pkg := lml
+debpkg := cl-lml
+
+
+clc-source := usr/share/common-lisp/source
+clc-systems := usr/share/common-lisp/systems
+clc-lml := $(clc-source)/$(pkg)
+
+doc-dir := usr/share/doc/$(debpkg)
+
+
+configure: configure-stamp
+configure-stamp:
+ dh_testdir
+ # Add here commands to configure the package.
+
+ touch configure-stamp
+
+
+build: build-stamp
+
+build-stamp: configure-stamp
+ dh_testdir
+
+ # Add here commands to compile the package.
+
+ touch build-stamp
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp configure-stamp
+
+ # Add here commands to clean up after the build process.
+ -$(MAKE) clean
+ rm -f debian/cl-lml.postinst.* debian/cl-lml.prerm.*
+
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ dh_installdirs --all $(clc-systems) $(clc-source)
+ dh_installdirs -p $(debpkg) $(doc-dir) $(clc-lml)/mcl
+
+ # Add here commands to install the package into debian/lml.
+ dh_install lml.system lml.asd $(clc-systems)
+ dh_install $(shell echo *.cl) $(clc-lml)
+
+ rm -rf doc/html
+ (cd doc; tar xzf html.tar.gz; cd ..)
+ dh_install doc/html $(doc-dir)
+ rm -rf doc/html
+ cp doc/lml.pdf doc/cl-lml.pdf
+ gzip -9 doc/cl-lml.pdf
+ dh_install doc/cl-lml.pdf.gz $(doc-dir)
+
+# Build architecture-independent files here.
+binary-indep: build install
+
+
+# Build architecture-dependent files here.
+binary-arch: build install
+ dh_testdir
+ dh_testroot
+# dh_installdebconf
+ dh_installdocs
+ dh_installexamples examples/*.cl
+# dh_installmenu
+# dh_installlogrotate
+# dh_installemacsen
+# dh_installpam
+# dh_installmime
+# dh_installinit
+# dh_installcron
+# dh_installman
+# dh_installinfo
+# dh_undocumented
+ dh_installchangelogs ChangeLog
+ dh_strip
+ dh_compress
+ dh_fixperms
+# dh_makeshlibs
+ dh_installdeb
+# dh_perl
+ dh_shlibdeps
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install configure
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: downloads.cl
+;;;; Purpose: Generate downloads page
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: downloads.cl,v 1.1 2002/09/16 01:13:49 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)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+
+(defvar *ftp-base*)
+(defvar *ftp-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-ftp-base (file)
+ (let ((fdir (pathname-directory file))
+ (bdir (pathname-directory *ftp-base*)))
+ (make-pathname
+ :name (pathname-name file)
+ :type (pathname-type file)
+ :directory
+ (when (> (length bdir) (length fdir))
+ (append '(:absolute)
+ (subseq (length bdir) (length fdir) fdir))))))
+
+(defun print-file (file)
+ (let ((size (round (/ (file-length file) 1024)))
+ (modtime (date-string (file-write-date file)))
+ (basename (namestring
+ (make-pathname :name (pathname-name file)
+ :type (pathname-type file))))
+ (ftp-name (strip-ftp-base file))
+ (sig-path
+ (make-pathname :defaults file
+ :type
+ (concatenate 'string
+ (pathname-type file) ".asc"))))
+ (lml-print "<a href=\"~A~A\">~A</a>" *ftp-url* ftp-name basename)
+ (lml-print "<span class=\"modtime\">")
+ (lml-print " (~A, <b>~:D <span style=\"font-size:90%;\">KB</span></b>)</span>" modtime size)
+ (when (probe-file sig-path)
+ (setq *signed* t)
+ (lml-print " [<a href=\"~A~A.asc\">Signature</a>]" *ftp-url* ftp-name))
+ (br)))
+
+(defun display-header (name url)
+ (lml-print "<h1>Download</h1>")
+ (lml-print "<div class=\"mainbody\">")
+ (lml-print "<h3>Browse ~A FTP Site</h3>" name)
+ (lml-print "<a style=\"padding-left:20pt;\" href=\"~A\">~A</a>" url url))
+
+(defun display-footer ()
+ (when *signed*
+ (lml-print "<h3>GPG Public Key</h3>")
+ (lml-print "Use this <a href=\"https://www.b9.com/key.asc\">key</a> to verify file signtatures"))
+ (lml-print "</div>"))
+
+(defun print-sect-title (title)
+ (lml-print "<h~D>~A</h~D>" *section-indent* title *section-indent*))
+
+(defun filter-against-base (files)
+ (let ((filtered '()))
+ (dolist (f files)
+ (let ((name (pathname-name f)))
+ (when
+ (block search
+ (dotimes (i (length *base-name*))
+ (declare (fixnum i))
+ (unless (char= (char *base-name* i)
+ (char name i))
+ (return-from search nil)))
+ t)
+ (push f filtered))))
+ (sort filtered #'(lambda (a b) (string<
+ (namestring a)
+ (namestring b))))))
+
+(defun display-one-section (title pat)
+ (let ((files (filter-against-base (directory pat))))
+ (when files
+ (print-sect-title title)
+ (lml-print "<div style=\"padding-left: 20pt;\">")
+ (list-files files)
+ (lml-print"</div>"))))
+
+
+(defun display-sections (sects)
+ (when sects
+ (let ((title (car sects))
+ (value (cadr sects)))
+ (if (consp title)
+ (mapcar #'display-sections sects)
+ (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 ftp-base ftp-url sects)
+ (let ((*section-indent* 3)
+ (*ftp-base* ftp-base)
+ (*ftp-url* ftp-url)
+ (*base-name* pkg-base)
+ (*signed* nil))
+ (display-header pkg-name ftp-url)
+ (mapcar #'display-sections sects)
+ (display-footer)))
+
+(defun std-dl-page (pkg-name pkg-base ftp-base ftp-url)
+ (let ((base (parse-namestring ftp-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 ftp-base ftp-url
+ `(("Manual" ,doc-path)
+ ("Source Code"
+ (("Unix (.tar.gz)" ,tgz-path)
+ ("Windows (.zip)" ,zip-path))))))))
+
+(defun full-dl-page (pkg-name pkg-base ftp-base ftp-url)
+ (let ((base (parse-namestring ftp-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 "w32")
+ :type :wild :name :wild)
+ base)))
+ (display-page pkg-name pkg-base ftp-base ftp-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 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)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar *output-dir* nil)
+ (defvar *sources-dir* nil)
+ )
+
+(defvar *html-output* *standard-output*)
+
+(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-dir &key sources) &body body)
+ (when (stringp output-dir)
+ (setq output-dir (parse-namestring output-dir)))
+ (unless sources
+ (setq sources output-dir))
+ `(let ((*output-dir* ,output-dir)
+ (*sources-dir* ,sources))
+ ,@body))
+
+(defun lml-load-path (file)
+ (if (probe-file file)
+ (with-open-file (in file :direction :input)
+ (do ((form (read in nil 'lml::eof) (read in nil 'lml::eof)))
+ ((eq form 'lml::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-output*))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: lml.asd
+;;;; Purpose: ASDF definition file for Lisp Markup Language
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: lml.asd,v 1.1 2002/09/16 01:13:49 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 :asdf)
+
+(defsystem :lml
+ :default-component-class kmr-cl-source-file
+ :pathname #.(translate-logical-pathname "KLISP-CVS:lml;")
+ :components
+ ((:file "package")
+ (:file "utils" :depends-on ("package"))
+ (:file "files" :depends-on ("utils"))
+ (:file "lml" :depends-on ("files"))
+ (:file "stdsite" :depends-on ("lml"))
+ (:file "downloads" :depends-on ("lml"))
+ (:file "pgsite" :depends-on ("lml"))
+ ))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: lml.cl
+;;;; Purpose: Lisp Markup Language functions
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: lml.cl,v 1.1 2002/09/16 01:13:49 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)
+;;;; *************************************************************************
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+(defconstant +html4-prologue-string+
+ (format nil
+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">~%"))
+
+(defconstant +xml-prologue-string+
+ (format nil
+ "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>~%"))
+
+(defconstant +xhtml-prologue-string+
+ (format nil
+ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">~%"))
+
+(defvar *print-spaces* nil)
+(defvar *indent* 0)
+(defun reset-indent ()
+ (setq *indent* 0))
+
+(defun lml-print (str &rest args)
+ (when (streamp *html-output*)
+ (when *print-spaces* (indent-spaces *indent* *html-output*))
+ (if args
+ (apply #'format *html-output* str args)
+ (princ str *html-output*))
+ (when *print-spaces* (format *html-output* "~%"))
+ (values)))
+
+(defmacro lml-line (str &rest args)
+ `(lml-print ,str ,@args))
+
+(defun lml-print-date (date)
+ (lml-print (date-string date)))
+
+(defmacro lml-exec-body (&body forms)
+ `(progn
+ ,@(mapcar
+ #'(lambda (form)
+ (etypecase form
+ (string
+ `(lml-print ,form))
+ (number
+ `(lml-print "~D" ,form))
+ (symbol
+ `(lml-print (string-downcase (symbol-name ,form))))
+ (nil
+ nil)
+ (cons
+ form)))
+ forms)))
+
+(defmacro with-attr-string (tag attr-string &body body)
+ (let ((attr (gensym)))
+ `(let ((,attr ,attr-string))
+ (lml-print "<~(~A~)~A>" ',tag
+ (if (and (stringp ,attr) (plusp (length ,attr)))
+ (format nil "~A" ,attr)
+ ""))
+ (incf *indent*)
+ (lml-exec-body ,@body)
+ (decf *indent*)
+ (lml-print "</~(~A~)>" ',tag))))
+
+(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)))))
+
+(defmacro with-keyargs (tag keyargs &body body)
+ (let ((attr (gensym))
+ (kv (gensym)))
+ `(progn
+ (let ((,attr '()))
+ (dolist (,kv ',keyargs)
+ (awhen (cadr ,kv)
+ (push (one-keyarg-string (car ,kv) it) ,attr)))
+ (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
+
+(defmacro with (tag &rest args)
+ (let ((body '())
+ (keyargs '())
+ (n (length args)))
+ (do ((i 0 (1+ i)))
+ ((> i (1- n)))
+ (let ((arg (nth i args))
+ (value (when (< (1+ i) n)
+ (nth (1+ i) args))))
+ (if (keyword-symbol? arg)
+ (progn
+ (push (list arg value) keyargs)
+ (incf i))
+ (push arg body))))
+ `(with-keyargs ,tag ,keyargs ,@(nreverse body))))
+
+
+(defmacro keyargs-string (&rest args)
+ "Returns a string of attributes and values. Result contains a leading space."
+ (let ((keyarg-list '()))
+ (loop for ( name val ) on args by #'cddr
+ do
+ (when val
+ (push (one-keyarg-string name val) keyarg-list)))
+ (list-to-spaced-string (nreverse keyarg-list))))
+
+
+(defmacro xhtml-prologue ()
+ `(progn
+ (lml-print +xml-prologue-string+)
+ (lml-print +xhtml-prologue-string+)))
+
+(defmacro link (dest &body body)
+ `(with a :href ,dest ,@body))
+
+(defmacro link-c (class dest &body body)
+ `(with a :href ,dest :class ,class ,@body))
+
+(defmacro img (dest &key class id alt style width height align)
+ (let ((attr
+ (eval `(keyargs-string :class ,class :id ,id :alt ,alt :style ,style
+ :width ,width :height ,height :align ,align))))
+ `(lml-print ,(format nil "<img src=\"~A\"~A />" dest attr))))
+
+(defmacro input (&key name class id type style size maxlength value)
+ (let ((attr
+ (eval `(keyargs-string :name ,name :class ,class :id ,id :style ,style
+ :size ,size :maxlength ,maxlength :value ,value
+ :type ,type))))
+ `(lml-print ,(format nil "<input~A />" attr))))
+
+(defmacro meta (name content)
+ `(with meta :name ,name :content ,content))
+
+(defmacro meta-key (&key name content http-equiv)
+ `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
+
+(defmacro br ()
+ `(lml-print "<br />"))
+
+(defmacro lml-tag-macro (tag)
+ `(progn
+ (defmacro ,tag (&body body)
+ `(with ,',tag ,@body))
+ (export ',tag)))
+
+(defmacro lml-tag-class-macro (tag)
+ (let ((name (intern (format nil "~A-~A" tag :c))))
+ `(progn
+ (defmacro ,name (&body body)
+ `(with ,',tag :class ,(car body) ,@(cdr body)))
+ (export ',name))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparameter *macro-list*
+ '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td tr body head
+ html title pre tt u dl dt dd kbd code form))
+ (export '(link link-c br img input meta meta-key))
+ (export *macro-list*))
+
+(loop for i in *macro-list*
+ do
+ (eval `(lml-tag-macro ,i))
+ (eval `(lml-tag-class-macro ,i)))
+
+(defmacro print-page (title &body body)
+ `(html
+ (head
+ (title ,title))
+ (body ,@body)))
+
+(defmacro page (out-file &body body)
+ `(with-open-file (*html-output*
+ (lml-file-name ,out-file :output)
+ :direction :output
+ :if-exists :supersede)
+ (xhtml-prologue)
+ (html :xmlns "http://www.w3.org/1999/xhtml"
+ ,@body)))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10 -*-
+;;;; $Id: lml.system,v 1.1 2002/09/16 01:13:49 kevin Exp $
+
+(declaim (optimize (speed 3) (safety 1)))
+
+(in-package :cl-user)
+
+(mk:defsystem :lml
+ :source-pathname #.(translate-logical-pathname "KLISP-CVS:lml;")
+ :source-extension "cl"
+ :binary-pathname #.(translate-logical-pathname "KLISP-CVS:lml;bin;")
+ :components
+ ((:file "package")
+ (:file "utils") :depends-on ("package")
+ (:file "files") :depends-on ("utils")
+ (:file "lml" :depends-on ("files"))
+ (:file "stdsite" :depends-on ("lml"))
+ (:file "downloads" :depends-on ("lml"))
+ (:file "pgsite" :depends-on ("lml")))
+ :depends-on (:genutils))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: package.cl
+;;;; Purpose: Package file for Lisp Markup Language
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: package.cl,v 1.1 2002/09/16 01:13:49 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 :cl-user)
+
+(defpackage #:lisp-markup-language
+ (:nicknames #:lml)
+ (:export
+
+ ;; lml.cl
+ #:reset-indent
+ #:with
+ #:print-page
+ #:page
+ #:lml-print
+ #:lml-print-date
+
+ ;; files.cl
+ #:with-dir
+ #:process-dir
+ #:lml-load
+ #:include-file
+
+ ;; stdsite.cl
+ #:print-std-page
+ #:std-page
+ #:std-body
+ #:std-head
+ #:titled-pre-section
+
+ ;; downloads.cl
+ #:std-dl-page
+ #:full-dl-page
+))
--- /dev/null
+(in-package :lml)
+
+;;; Not currently used
+
+(defun brs (&optional (n 1))
+ (fresh-line)
+ (dotimes (i n)
+ (princ "<br>"))
+ (terpri))
+
+
+(defun html-file (base &optional (ext 'html))
+ (format nil "~(~A~).~(~A~)" base ext))
+
+(defmacro link-item (dest text)
+ `(progn
+ (princ "<li>")
+ (link ,dest
+ (princ ,text))))
+
+(defun button (dest text)
+ `(progn
+ (princ "[ ")
+ (link ,dest
+ (princ ,text))
+ (format t " ]~%")))
+
+
+(defun map3 (fn lst)
+ (labels ((rec (curr prev next left)
+ (funcall fn curr prev next)
+ (when left
+ (rec (car left)
+ curr
+ (cadr left)
+ (cdr left)))))
+ (when lst
+ (rec (car lst) nil (cadr lst) (cdr lst)))))
+
+
+(defparameter *sections* nil)
+
+(defstruct item
+ id title text)
+
+(defstruct section
+ id title items)
+
+(defmacro defitem (id title text)
+ `(setf ,id
+ (make-item :id ',id
+ :title ,title
+ :text ,text)))
+
+(defmacro defsection (id title &body items)
+ `(setf ,id
+ (make-section :id ',id
+ :title ,title
+ :items (list ,@items))))
+
+(defmacro defsite (&body sections)
+ `(progn
+ (setf *sections* ,sections)))
+
+
+(defconstant contents "contents")
+(defconstant index "index")
+
+(defun gen-contents (&optional (sections *sections*))
+ (page (html-file contents)
+ contents
+ (ol
+ (dolist (s sections)
+ (link-item (section-id s) (section-title s))
+ (brs 2))
+ (link-item index (string-capitalize index)))))
+
+(defun gen-index (&optional (sections *sections*))
+ (page (html-file index)
+ index
+ (ol
+ (dolist (i (all-items sections))
+ (link-item (item-id i) (item-title i))
+ (brs 2)))))
+
+(defun all-items (sections)
+ (let ((is nil))
+ (dolist (s sections)
+ (dolist (i (section-items s))
+ (setf is (merge 'list (list i) is #'title<))))
+ is))
+
+(defun title< (x y)
+ (string-lessp (item-title x) (item-title y)))
+
+
+(defun gen-site ()
+ (map3 #'gen-section *sections*)
+ (gen-contents)
+ (gen-index))
+
+(defun gen-section (sect <sect sect>)
+ (page (html-file (section-id sect))
+ (section-title sect)
+ (progn
+ (with ol
+ (map3 #'(lambda (item <item item>)
+ (link-item (item-id item)
+ (item-title item))
+ (brs 2)
+ (gen-item sect item <item item>))
+ (section-items sect)))
+ (brs 3)
+ (gen-move-buttons (if <sect (section-id <sect))
+ contents
+ (if sect> (section-id sect>))))))
+
+(defun gen-item (sect item <item item>)
+ (page (html-file (item-id item))
+ (item-title item)
+ (progn
+ (princ (item-text item))
+ (brs 3)
+ (gen-move-buttons (if <item (item-id <item))
+ (section-id sect)
+ (if item> (item-id item>))))))
+
+(defun gen-move-buttons (back up forward)
+ (if back (button back "Back"))
+ (if up (button up "Up"))
+ (if forward (button forward "Forward")))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; Name: stdsite.cl
+;;;; Purpose: Functions to create my standard style sites
+;;;; Programmer: Kevin M. Rosenberg
+;;;; Date Started: Aug 2002
+;;;;
+;;;; $Id: stdsite.cl,v 1.1 2002/09/16 01:13:49 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)
+;;;; *************************************************************************
+
+;;; A "standard site" is a format for a certain style of web page.
+;;; It is based on the LML package.
+;;; A stdsite page expects to include the following files:
+;;; head.lml_
+;;; banner.lml_
+;;; content.lml_
+;;; footer.lml_
+
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+(in-package :lml)
+
+(defmacro std-head (title &body body)
+ `(head
+ (title ,title)
+ (lml-load #p"head.lml_")
+ ,@body))
+
+
+(defun std-footer (file)
+ (div-c "disclaimsec"
+ (let ((ds (date-string
+ (file-write-date (make-pathname
+ :defaults *sources-dir*
+ :type "lml"
+ :name (pathname-name file))))))
+ (when ds
+ (div-c "lastmod"
+ (lml-print "Last modified: ~A" ds)))))
+ (lml-load #p"footer.lml_")
+ (values))
+
+
+(defmacro std-body (file &body body)
+ `(body
+ (lml-load #p"banner.lml_")
+ (table-c "stdbodytable" :border "0" :cellpadding "3"
+ (tbody
+ (tr :valign "top"
+ (td-c "stdcontentcell"
+ (lml-load #p"contents.lml_"))
+ (td :valign "top"
+ ,@body
+ (std-footer ,file)))))))
+
+
+(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))))
+
+(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)
+ (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)))
+
+
+
--- /dev/null
+;;; $Id: utils.cl,v 1.1 2002/09/16 01:13:49 kevin Exp $
+;;;;
+;;;; General purpose utilities
+
+(in-package :lml)
+
+
+(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 indent-spaces (n &optional (stream *standard-output*))
+ "Indent n*2 spaces to output stream"
+ (let ((fmt (format nil "~~~D~~T" (+ n n))))
+ (format stream fmt)))
+
+(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))
+ (format strm "~A~%" line)))))
+
+(defun date-string (ut)
+ (if (typep 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))))
+
projects / lml.git / commitdiff