From f212998e69e8b67604a1f96faaf1ecacf693c5c3 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 16 Sep 2002 01:13:49 +0000 Subject: [PATCH] r2656: initial import --- .cvsignore | 1 + debian/changelog | 6 ++ debian/control | 13 +++ debian/copyright | 92 +++++++++++++++++++++ debian/postinst | 52 ++++++++++++ debian/prerm | 42 ++++++++++ debian/rules | 98 +++++++++++++++++++++++ downloads.cl | 167 +++++++++++++++++++++++++++++++++++++++ files.cl | 77 ++++++++++++++++++ lml.asd | 32 ++++++++ lml.cl | 202 +++++++++++++++++++++++++++++++++++++++++++++++ lml.system | 20 +++++ package.cl | 49 ++++++++++++ pgsite.cl | 131 ++++++++++++++++++++++++++++++ stdsite.cl | 85 ++++++++++++++++++++ utils.cl | 51 ++++++++++++ 16 files changed, 1118 insertions(+) create mode 100644 .cvsignore create mode 100644 debian/changelog create mode 100644 debian/control create mode 100644 debian/copyright create mode 100644 debian/postinst create mode 100644 debian/prerm create mode 100755 debian/rules create mode 100644 downloads.cl create mode 100644 files.cl create mode 100644 lml.asd create mode 100644 lml.cl create mode 100644 lml.system create mode 100644 package.cl create mode 100644 pgsite.cl create mode 100644 stdsite.cl create mode 100644 utils.cl diff --git a/.cvsignore b/.cvsignore new file mode 100644 index 0000000..ca8d09f --- /dev/null +++ b/.cvsignore @@ -0,0 +1 @@ +.bin diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..a4780cc --- /dev/null +++ b/debian/changelog @@ -0,0 +1,6 @@ +lml (1.0.0-1) unstable; urgency=low + + * Initial Release. + + -- Kevin M. Rosenberg Sun, 15 Sep 2002 17:00:47 -0600 + diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..9c8e5e3 --- /dev/null +++ b/debian/control @@ -0,0 +1,13 @@ +Source: lml +Section: devel +Priority: optional +Maintainer: Kevin M. Rosenberg +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. + diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..96207a5 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,92 @@ +Debian Copyright Section +======================== + +Upstream Source URL: ftp://lml.med-info.com +Upstream Author: Kevin M. Rosenberg +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. + diff --git a/debian/postinst b/debian/postinst new file mode 100644 index 0000000..d9021dc --- /dev/null +++ b/debian/postinst @@ -0,0 +1,52 @@ +#! /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: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# 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 + + diff --git a/debian/prerm b/debian/prerm new file mode 100644 index 0000000..3911106 --- /dev/null +++ b/debian/prerm @@ -0,0 +1,42 @@ +#! /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: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# 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 + + diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..f91dab9 --- /dev/null +++ b/debian/rules @@ -0,0 +1,98 @@ +#!/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 + diff --git a/downloads.cl b/downloads.cl new file mode 100644 index 0000000..3889dea --- /dev/null +++ b/downloads.cl @@ -0,0 +1,167 @@ +;;;; -*- 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" *ftp-url* ftp-name basename) + (lml-print "") + (lml-print " (~A, ~:D KB)" modtime size) + (when (probe-file sig-path) + (setq *signed* t) + (lml-print " [Signature]" *ftp-url* ftp-name)) + (br))) + +(defun display-header (name url) + (lml-print "

Download

") + (lml-print "
") + (lml-print "

Browse ~A FTP Site

" name) + (lml-print "~A" url url)) + +(defun display-footer () + (when *signed* + (lml-print "

GPG Public Key

") + (lml-print "Use this key to verify file signtatures")) + (lml-print "
")) + +(defun print-sect-title (title) + (lml-print "~A" *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 "
") + (list-files files) + (lml-print"
")))) + + +(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)))))))) diff --git a/files.cl b/files.cl new file mode 100644 index 0000000..75b3773 --- /dev/null +++ b/files.cl @@ -0,0 +1,77 @@ +;;;; -*- 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*)) diff --git a/lml.asd b/lml.asd new file mode 100644 index 0000000..234bb77 --- /dev/null +++ b/lml.asd @@ -0,0 +1,32 @@ +;;;; -*- 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")) + )) diff --git a/lml.cl b/lml.cl new file mode 100644 index 0000000..b273b2c --- /dev/null +++ b/lml.cl @@ -0,0 +1,202 @@ +;;;; -*- 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 + "~%")) + +(defconstant +xml-prologue-string+ + (format nil + "~%")) + +(defconstant +xhtml-prologue-string+ + (format nil + "~%")) + +(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 "" ',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 "" 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 "" 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 "
")) + +(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))) diff --git a/lml.system b/lml.system new file mode 100644 index 0000000..853c810 --- /dev/null +++ b/lml.system @@ -0,0 +1,20 @@ +;;;; -*- 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)) diff --git a/package.cl b/package.cl new file mode 100644 index 0000000..0bb6a0b --- /dev/null +++ b/package.cl @@ -0,0 +1,49 @@ +;;;; -*- 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 +)) diff --git a/pgsite.cl b/pgsite.cl new file mode 100644 index 0000000..f2a95a2 --- /dev/null +++ b/pgsite.cl @@ -0,0 +1,131 @@ +(in-package :lml) + +;;; Not currently used + +(defun brs (&optional (n 1)) + (fresh-line) + (dotimes (i n) + (princ "
")) + (terpri)) + + +(defun html-file (base &optional (ext 'html)) + (format nil "~(~A~).~(~A~)" base ext)) + +(defmacro link-item (dest text) + `(progn + (princ "
  • ") + (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 ) + (page (html-file (section-id sect)) + (section-title sect) + (progn + (with ol + (map3 #'(lambda (item ) + (link-item (item-id item) + (item-title item)) + (brs 2) + (gen-item sect item )) + (section-items sect))) + (brs 3) + (gen-move-buttons (if (section-id sect>)))))) + +(defun gen-item (sect item ) + (page (html-file (item-id item)) + (item-title item) + (progn + (princ (item-text item)) + (brs 3) + (gen-move-buttons (if (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"))) diff --git a/stdsite.cl b/stdsite.cl new file mode 100644 index 0000000..8fab145 --- /dev/null +++ b/stdsite.cl @@ -0,0 +1,85 @@ +;;;; -*- 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))) + + + diff --git a/utils.cl b/utils.cl new file mode 100644 index 0000000..77feece --- /dev/null +++ b/utils.cl @@ -0,0 +1,51 @@ +;;; $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)))) + -- 2.34.1