From: Kevin M. Rosenberg Date: Mon, 16 Sep 2002 01:13:49 +0000 (+0000) Subject: r2656: initial import X-Git-Tag: v2.5.5~199 X-Git-Url: http://git.kpe.io/?p=lml.git;a=commitdiff_plain;h=f212998e69e8b67604a1f96faaf1ecacf693c5c3 r2656: initial import --- f212998e69e8b67604a1f96faaf1ecacf693c5c3 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)))) +