From 096b456fe920373f3b54fbe47f10f3e41c4fe925 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 20 Jun 2003 04:12:29 +0000 Subject: [PATCH] r5163: *** empty log message *** --- 2/.cvsignore | 11 + 2/api.lisp | 99 +++++++ 2/base.lisp | 71 +++++ 2/data.lisp | 33 +++ 2/doc/Makefile | 10 + 2/doc/make.lisp | 7 + 2/doc/readme.html | 9 + 2/doc/readme.lml | 73 +++++ 2/downloads.lisp | 168 +++++++++++ 2/files.lisp | 80 +++++ 2/htmlgen.lisp | 738 ++++++++++++++++++++++++++++++++++++++++++++++ 2/ifstar.lisp | 61 ++++ 2/lml2-tests.asd | 26 ++ 2/lml2.asd | 47 +++ 2/package.lisp | 65 ++++ 2/read-macro.lisp | 82 ++++++ 2/stdsite.lisp | 89 ++++++ 2/tests.lisp | 69 +++++ 2/utils.lisp | 82 ++++++ 19 files changed, 1820 insertions(+) create mode 100644 2/.cvsignore create mode 100644 2/api.lisp create mode 100644 2/base.lisp create mode 100644 2/data.lisp create mode 100644 2/doc/Makefile create mode 100644 2/doc/make.lisp create mode 100644 2/doc/readme.html create mode 100644 2/doc/readme.lml create mode 100644 2/downloads.lisp create mode 100644 2/files.lisp create mode 100644 2/htmlgen.lisp create mode 100644 2/ifstar.lisp create mode 100644 2/lml2-tests.asd create mode 100644 2/lml2.asd create mode 100644 2/package.lisp create mode 100644 2/read-macro.lisp create mode 100644 2/stdsite.lisp create mode 100644 2/tests.lisp create mode 100644 2/utils.lisp diff --git a/2/.cvsignore b/2/.cvsignore new file mode 100644 index 0000000..5593b39 --- /dev/null +++ b/2/.cvsignore @@ -0,0 +1,11 @@ +.bin +*.fasl* +*.fas +*.x86f +*.ufsl +*.dfsl +*.fsl +*.cfsl +*.x86f +*.sparcf + diff --git a/2/api.lisp b/2/api.lisp new file mode 100644 index 0000000..0e291b2 --- /dev/null +++ b/2/api.lisp @@ -0,0 +1,99 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: api.lisp +;;;; Purpose: Macros for generating API documentation +;;;; Programmer: Kevin M. Rosenberg based on Matthew Danish's code +;;;; Date Started: Nov 2002 +;;;; +;;;; $Id: api.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; and Copyright (c) 2002 Matthew Danish +;;;; +;;;; LML users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:lml) + +;;; Copyright (c) 2002 Matthew Danish. +;;; All rights reserved. + +;;; Redistribution and use in source and binary forms, with or without +;;; modification, are permitted provided that the following conditions +;;; are met: +;;; 1. Redistributions of source code must retain the above copyright +;;; notice, this list of conditions and the following disclaimer. +;;; 2. Redistributions in binary form must reproduce the above copyright +;;; notice, this list of conditions and the following disclaimer in the +;;; documentation and/or other materials provided with the distribution. +;;; 3. The name of the author may not be used to endorse or promote products +;;; derived from this software without specific prior written permission. +;;; +;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +;;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +;;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +;;; IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +;;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +;;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +;;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +;;; For an example, see Matthew Danish's cl-ftp documentation at +;;; http://www.mapcar.org/~mrd/cl-sql/ + +(defmacro api-list (&body body) + `(ul ,@(loop for item in body collect `(li ,item)))) + +(defun stringify (x) + (let ((*print-case* :downcase)) + (if (null x) + "()" + (format nil "~A" x)))) + +(defmacro with-class-info ((class-name superclasses &rest slot-docs) &body other-info) + `(p (i "Class ") (b ,(stringify class-name)) + (i " derived from ") ,(stringify superclasses) " -- " (br) + (i "Initargs:") (br) + (ul + ,@(loop for (slot-name slot-desc slot-default) in slot-docs collect + `(li (tt ,(format nil ":~A" slot-name)) + " -- " ,slot-desc " -- " (i "Default: ") + ,(if (eql slot-default :n/a) + "Not specified" + (format nil "~S" slot-default))))) + ,@other-info)) + +(defmacro with-macro-info ((macro-name &rest lambda-list) &body other-info) + `(p (i "Macro ") (b ,(stringify macro-name)) " " + (tt ,(stringify lambda-list)) (br) + ,@other-info)) + +(defmacro with-function-info ((function-name &rest lambda-list) &body other-info) + `(p (i "Function ") (b ,(stringify function-name)) " " + (tt ,(stringify lambda-list)) + (br) ,@other-info)) + +(defmacro with-condition-info ((condition-name supers &rest slot-docs) &body other-info) + `(p (i "Condition ") (b ,(stringify condition-name)) + (i " derived from ") ,(stringify supers) " -- " (br) + (i "Slots:") (br) + (ul + ,@(loop for (slot-name slot-desc slot-reader slot-initarg slot-default) in slot-docs collect + `(li (tt ,(stringify slot-name)) + " -- " ,slot-desc " -- " (i " Default: ") + ,(if (eql slot-default :n/a) + "Not specified" + (format nil "~S" slot-default))))) + ,@other-info)) + +(defmacro with-functions (&rest slots) + `(progn ,@(loop for (fn description . args) in slots collect + `(with-function-info (,fn ,@(if args args + '(connection-variable))) + ,description)))) diff --git a/2/base.lisp b/2/base.lisp new file mode 100644 index 0000000..944df66 --- /dev/null +++ b/2/base.lisp @@ -0,0 +1,71 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: base.lisp +;;;; Purpose: Lisp Markup Language functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id: base.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:lml2) + + +(defun reset-indent () + (setq *indent* 0)) + +(defun lml-format (str &rest args) + (when (streamp *html-stream*) + (when *print-spaces* (indent-spaces *indent* *html-stream*)) + (if args + (apply #'format *html-stream* str args) + (write-string str *html-stream*)) + (when *print-spaces* (write-char #\newline *html-stream*)))) + +(defun lml-princ (s) + (princ s *html-stream*)) + +(defun lml-print (s) + (format *html-stream* "~A~%" s)) + +(defun lml-write-char (char) + (write-char char *html-stream*)) + +(defun lml-write-string (str) + (write-string str *html-stream*)) + +(defun lml-print-date (date) + (lml-write-string (date-string date))) + +(defmacro xhtml-prologue () + `(progn + (lml-write-string (xml-prologue-string)) + (lml-write-char #\newline) + (lml-write-string (xhtml-prologue-string)) + (lml-write-char #\newline))) + +(defmacro print-page (title &body body) + `(html + (:head + (:title (:princ ,title))) + (:body ,@body))) + +(defmacro page (out-file &body body) + `(with-open-file (*html-stream* + (lml-file-name ,out-file :output) + :direction :output + :if-exists :supersede) + (xhtml-prologue) + (html + ((:html :xmlns "http://www.w3.org/1999/xhtml") + ,@body)))) + + diff --git a/2/data.lisp b/2/data.lisp new file mode 100644 index 0000000..58aee92 --- /dev/null +++ b/2/data.lisp @@ -0,0 +1,33 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: data.lisp +;;;; Purpose: Lisp Markup Language functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id: data.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML2 users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:lml2) + +(defvar *html-stream* *standard-output*) + +(defvar *print-spaces* nil) +(defvar *indent* 0) + +(defun html4-prologue-string () + "") + +(defun xml-prologue-string () + "") + +(defun xhtml-prologue-string () + "") diff --git a/2/doc/Makefile b/2/doc/Makefile new file mode 100644 index 0000000..360c186 --- /dev/null +++ b/2/doc/Makefile @@ -0,0 +1,10 @@ +.PHONY: site all clean + +all: site + +site: + sbcl --userinit `pwd`/make.lisp + +clean: + @rm -f *~ \#*\# .\#* memdump + diff --git a/2/doc/make.lisp b/2/doc/make.lisp new file mode 100644 index 0000000..7d9b8ca --- /dev/null +++ b/2/doc/make.lisp @@ -0,0 +1,7 @@ +#+cmu (setq ext:*gc-verbose* nil) + +(require :lml2) +(in-package :lml2) +(let ((cwd (parse-namestring (lml-cwd)))) + (process-dir cwd)) +(lml-quit) diff --git a/2/doc/readme.html b/2/doc/readme.html new file mode 100644 index 0000000..3206126 --- /dev/null +++ b/2/doc/readme.html @@ -0,0 +1,9 @@ + + +LML README

LML Documentation

Overview

LML is a Common Lisp package for generating HTML and XHTML documents.LML is authored by Kevin Rosenberg. The home page for LML is http://lml.b9.com/.

Installation

The easiest way to install LML is to use the Debian GNU/Linux operating system. You can then use the command apt-get install cl-lml to automatically download and install the LML package.

On a non-Debian system, you need to have ASDF installed to load the system definition file. You will need to change the source + pathname in the system file to match the location where you have installed LML.

Usage

Currently, there is no documentation on the functions provided by LML. However, the source code is instructive and there are example files included in the LML package.

Examples

Iteration
(html
+   (:i "The square of the first five integers are: )"
+   (:b
+   (loop as x from 1 to 5 
+     doing
+     (lml-format " ~D" (* x x))))
The square of the first five integers are: 1 4 9 16 25

View this page's LML source.

\ No newline at end of file diff --git a/2/doc/readme.lml b/2/doc/readme.lml new file mode 100644 index 0000000..d64fcde --- /dev/null +++ b/2/doc/readme.lml @@ -0,0 +1,73 @@ +;;; -*- Mode: Lisp -*- + +(in-package #:lml2) + +(page "readme" + (html + (:head + (:title "LML README") + ((:meta :http-equiv "Content-Type" :content "text/html; charset=iso-8859-1")) + ((:meta :name "Copyright" :content "Kevin Rosenberg 2002 ")) + ((:meta :name "description" :content "Lisp Markup Language Documentation")) + ((:meta :name "author" :content "Kevin Rosenberg")) + ((:meta :name "keywords" :content "Common Lisp, HTML, Markup Langauge"))) + + (:body + (:h1 "LML Documentation") + (:h2 "Overview") + (:p + ((:a :href "http://lml.b9.com") "LML") + " is a Common Lisp package for generating HTML and XHTML documents." + "LML is authored by " + ((:a :href "mailto:kevin@rosenberg.net") "Kevin Rosenberg") + ". The home page for LML is " + ((:a :href "http://lml.b9.com/") "http://lml.b9.com/") + ".") + + (:h2 "Installation") + (:p + "The easiest way to install LML is to use the " + ((:a :href "http://www.debian.org/") "Debian") + " GNU/Linux operating system. You can then use the command " + (:tt "apt-get install cl-lml") + " to automatically download and install the LML package.") + (:p + "On a non-Debian system, you need to have " + ((:a :href "http://cclan.sourceforge.net/") "ASDF") + " installed to load the system definition file. You will need to change the source + pathname in the system file to match the location where you have installed LML.") + + (:h2 "Usage") + (:p + "Currently, there is no documentation on the functions provided by LML. However, the source code is instructive and there are example files included in the LML package.") + + (:h2 "Examples") + ((:table :border 1 :cellpadding 3) + (:tbody + (:tr + ((:td :colspan 2 :style "color:#000;background-color:#ccc;font-weight:bold;") + "Iteration")) + (:tr + (:td + (:pre +"(html + (:i \"The square of the first five integers are: )\" + (:b + (loop as x from 1 to 5 + doing + (lml-format \" ~D\" (* x x))))")) + (:td + (:i "The square of the first five integers are: ") + (:b + (loop as x from 1 to 5 + doing + (lml-format " ~D" (* x x)))))) + )) + :hr + (:p + "View this page's " + ((:a :href "http://lml.b9.com/") "LML") + " " + ((:a :href "readme.lml") "source") + ".") + ))) diff --git a/2/downloads.lisp b/2/downloads.lisp new file mode 100644 index 0000000..2b977c3 --- /dev/null +++ b/2/downloads.lisp @@ -0,0 +1,168 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: downloads.lisp +;;;; Purpose: Generate downloads page +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id: downloads.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML2 users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:lml2) + + +(defvar *dl-base*) +(defvar *dl-url*) +(defvar *base-name*) +(defvar *section-indent* 0) +(defvar *signed* nil) + +(defun list-files (files) + "List files in a directory for downloading" + ;;files.sort() + (mapcar #'print-file files)) + +(defun strip-dl-base (file) + (let ((fdir (pathname-directory file)) + (bdir (pathname-directory *dl-base*))) + (make-pathname + :name (pathname-name file) + :type (pathname-type file) + :directory + (when (> (length fdir) (length bdir)) + (append '(:absolute) + (subseq fdir (length bdir) (length fdir))))))) + +(defun print-file (file) + (let ((size 0) + (modtime (date-string (file-write-date file))) + (basename (namestring + (make-pathname :name (pathname-name file) + :type (pathname-type file)))) + (dl-name (strip-dl-base file)) + (sig-path (concatenate 'string (namestring file) ".asc"))) + (when (plusp (length basename)) + (with-open-file (strm file :direction :input) + (setq size (round (/ (file-length strm) 1024)))) + (lml-format "~A" *dl-url* dl-name basename) + (lml-princ "") + (lml-format " (~A, ~:D KB)" modtime size) + (when (probe-file sig-path) + (setq *signed* t) + (lml-format " [Signature]" *dl-url* dl-name)) + (html :br)))) + +(defun display-header (name url) + (lml-princ "

Download

") + (lml-princ "
") + (lml-format "

Browse ~A Download Site

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

GPG Public Key

") + (lml-princ "Use this key to verify file signtatures")) + (lml-princ "
")) + +(defun print-sect-title (title) + (lml-format "~A" *section-indent* title *section-indent*)) + +(defun match-base-name? (name) + (let ((len-base-name (length *base-name*))) + (when (>= (length name) len-base-name) + (string= name *base-name* :end1 len-base-name :end2 len-base-name)))) + +(defun match-base-name-latest? (name) + (let* ((latest (concatenate 'string *base-name* "-latest")) + (len-latest (length latest))) + (when (>= (length name) len-latest) + (string= name latest :end1 len-latest :end2 len-latest)))) + +(defun filter-against-base (files) + (delete-if-not #'(lambda (f) (match-base-name? (pathname-name f))) files)) + +(defun filter-latest (files) + (delete-if #'(lambda (f) (match-base-name-latest? (pathname-name f))) files)) + +(defun sort-pathnames (list) + (sort list #'(lambda (a b) (string< (namestring a) (namestring b))))) + +(defun display-one-section (title pat) + (let ((files (sort-pathnames (filter-latest + (filter-against-base (directory pat)))))) + (when files + (print-sect-title title) + (lml-princ "
") + (list-files files) + (lml-princ "
")))) + +(defun display-sections (sects) + (when sects + (let ((title (car sects)) + (value (cadr sects))) + (if (consp title) + (dolist (sect sects) (display-sections sect)) + (if (consp value) + (progn + (print-sect-title title) + (incf *section-indent*) + (display-sections value) + (decf *section-indent*)) + (display-one-section title value)))))) + +(defun display-page (pkg-name pkg-base dl-base dl-url sects) + (let ((*section-indent* 3) + (*dl-base* dl-base) + (*dl-url* dl-url) + (*base-name* pkg-base) + (*signed* nil)) + (display-header pkg-name dl-url) + (map nil #'display-sections sects) + (display-footer))) + +(defun std-dl-page (pkg-name pkg-base dl-base dl-url) + (let ((base (parse-namestring dl-base))) + (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild)) + (zip-path (make-pathname :defaults base :type "zip" :name :wild)) + (doc-path (make-pathname :defaults base :type "pdf" :name :wild))) + (display-page pkg-name pkg-base dl-base dl-url + `(("Manual" ,doc-path) + ("Source Code" + (("Unix (.tar.gz)" ,tgz-path) + ("Windows (.zip)" ,zip-path)))))))) + +(defun full-dl-page (pkg-name pkg-base dl-base dl-url) + (let ((base (parse-namestring dl-base))) + (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild)) + (zip-path (make-pathname :defaults base :type "zip" :name :wild)) + (doc-path (make-pathname :defaults base :type "pdf" :name :wild)) + (deb-path (merge-pathnames + (make-pathname :directory '(:relative "linux-debian") + :type :wild :name :wild) + base)) + (rpm-path (merge-pathnames + (make-pathname :directory '(:relative "linux-rpm") + :type :wild :name :wild) + base)) + (w32-path (merge-pathnames + (make-pathname :directory '(:relative "win32") + :type :wild :name :wild) + base))) + (display-page pkg-name pkg-base dl-base dl-url + `(("Manual" ,doc-path) + ("Source Code" + (("Unix (.tar.gz)" ,tgz-path) + ("Windows (.zip)" ,zip-path))) + ("Binaries" + (("Linux Binaries" + (("Debian Linux" ,deb-path) + ("RedHat Linux" ,rpm-path))) + ("Windows Binaries" ,w32-path)))))))) diff --git a/2/files.lisp b/2/files.lisp new file mode 100644 index 0000000..9045cb4 --- /dev/null +++ b/2/files.lisp @@ -0,0 +1,80 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: files.cl +;;;; Purpose: File and directory functions for LML +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML2 users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:lml2) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *output-dir* nil) + (defvar *sources-dir* nil) + ) + +(defmacro lml-file-name (file &optional (type :source)) + (let ((f file)) + (when (and (consp f) (eql (car f) 'cl:quote)) + (setq f (cadr f))) + (when (symbolp f) + (setq f (string-downcase (symbol-name f)))) + (when (stringp f) + (unless (position #\. f) + (setq f (concatenate 'string f ".html")))) + (if *sources-dir* + (make-pathname :defaults (ecase type + (:source *sources-dir*) + (:output *output-dir*)) + :name `,(pathname-name f) + :type `,(pathname-type f)) + (if (stringp f) + (parse-namestring f) + f)))) + +(defmacro with-dir ((output &key sources) &body body) + (let ((output-dir (gensym)) + (sources-dir (gensym))) + `(let ((,output-dir ,output) + (,sources-dir ,sources)) + (when (stringp ,output-dir) + (setq ,output-dir (parse-namestring ,output-dir))) + (when (stringp ,sources-dir) + (setq ,sources-dir (parse-namestring ,sources-dir))) + (unless ,sources-dir + (setq ,sources-dir ,output-dir)) + (let ((*output-dir* ,output-dir) + (*sources-dir* ,sources-dir)) + ,@body)))) + +(defun lml-load-path (file) + (if (probe-file file) + (with-open-file (in file :direction :input) + (do ((form (read in nil 'eof) (read in nil 'eof))) + ((eq form 'eof)) + (eval form))) + (format *trace-output* "Warning: unable to load LML file ~S" file))) + +(defun process-dir (dir &key sources) + (with-dir (dir :sources sources) + (let ((lml-files (directory + (make-pathname :defaults *sources-dir* + :name :wild + :type "lml")))) + (dolist (file lml-files) + (format *trace-output* "~&; Processing ~A~%" file) + (lml-load-path file))))) + +(defun lml-load (file) + (lml-load-path (eval `(lml-file-name ,file :source)))) + +(defun include-file (file) + (print-file-contents file *html-stream*)) diff --git a/2/htmlgen.lisp b/2/htmlgen.lisp new file mode 100644 index 0000000..fdb76f1 --- /dev/null +++ b/2/htmlgen.lisp @@ -0,0 +1,738 @@ +;; -*- mode: common-lisp; package: lml2 -*- +;; +;; $Id: htmlgen.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;; +;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA +;; copyright (c) 2003 Kevin Rosenberg +;; +;; Main changes from Allegro version: +;; - Support XHTML +;; - lowercase symbol names +;; +;; This code is free software; you can redistribute it and/or +;; modify it under the terms of the version 2.1 of +;; the GNU Lesser General Public License as published by +;; the Free Software Foundation, as clarified by the AllegroServe +;; prequel found in license-allegroserve.txt. + + +(in-package #:lml2) + + +;; html generation + +(defstruct (html-process (:type list) (:constructor + make-html-process (key has-inverse + macro special + print + name-attr + ))) + key ; keyword naming this tag + has-inverse ; t if the / form is used + macro ; the macro to define this + special ; if true then call this to process the keyword and return + ; the macroexpansion + print ; function used to handle this in html-print + name-attr ; attribute symbols which can name this object for subst purposes + ) + + +(defparameter *html-process-table* + (make-hash-table :test #'equal) ; #'eq is accurate but want to avoid rehashes + ) + +(defmacro html (&rest forms &environment env) + ;; just emit html to the current stream + (process-html-forms forms env)) + +(defmacro html-out-stream-check (stream) + ;; ensure that a real stream is passed to this function + `(let ((.str. ,stream)) + (if* (not (streamp .str.)) + then (error "html-stream must be passed a stream object, not ~s" + .str.)) + .str.)) + + +(defmacro html-stream (stream &rest forms) + ;; set output stream and emit html + `(let ((*html-stream* (html-out-stream-check ,stream))) (html ,@forms))) + + +(defun process-html-forms (forms env) + (let (res) + (flet ((do-ent (ent args argsp body) + ;; ent is an html-process object associated with the + ;; html tag we're processing + ;; args is the list of values after the tag in the form + ;; ((:tag &rest args) ....) + ;; argsp is true if this isn't a singleton tag (i.e. it has + ;; a body) .. (:tag ...) or ((:tag ...) ...) + ;; body is the body if any of the form + ;; + (let (spec) + (if* (setq spec (html-process-special ent)) + then ; do something different + (push (funcall spec ent args argsp body) res) + elseif (null argsp) + then ; singleton tag, just do the set + (push `(,(html-process-macro ent) :set) res) + nil + else (if* (equal args '(:unset)) + then ; ((:tag :unset)) is a special case. + ; that allows us to close off singleton tags + ; printed earlier. + (push `(,(html-process-macro ent) :unset) res) + nil + else ; some args + (push `(,(html-process-macro ent) ,args + ,(process-html-forms body env)) + res) + nil))))) + + + + (do* ((xforms forms (cdr xforms)) + (form (car xforms) (car xforms))) + ((null xforms)) + + (setq form (macroexpand form env)) + + (if* (atom form) + then (if* (keywordp form) + then (let ((ent (gethash form *html-process-table*))) + (if* (null ent) + then (error "unknown html keyword ~s" + form) + else (do-ent ent nil nil nil))) + elseif (stringp form) + then ; turn into a print of it + (push `(write-string ,form *html-stream*) res) + else (push form res)) + else (let ((first (car form))) + (if* (keywordp first) + then ; (:xxx . body) form + (let ((ent (gethash first + *html-process-table*))) + (if* (null ent) + then (error "unknown html keyword ~s" + form) + else (do-ent ent nil t (cdr form)))) + elseif (and (consp first) (keywordp (car first))) + then ; ((:xxx args ) . body) + (let ((ent (gethash (car first) + *html-process-table*))) + (if* (null ent) + then (error "unknown html keyword ~s" + form) + else (do-ent ent (cdr first) t (cdr form)))) + else (push form res)))))) + `(progn ,@(nreverse res)))) + + +(defun html-atom-check (args open close body) + (if* (and args (atom args)) + then (let ((ans (case args + (:set `(write-string ,open *html-stream*)) + (:unset `(write-string ,close *html-stream*)) + (t (error "illegal arg ~s to ~s" args open))))) + (if* (and ans body) + then (error "can't have a body form with this arg: ~s" + args) + else ans)))) + +(defun html-body-form (open close body) + ;; used when args don't matter + `(progn (write-string ,open *html-stream*) + ,@body + (write-string ,close *html-stream*))) + + +(defun html-body-key-form (string-code has-inv args body) + ;; do what's needed to handle given keywords in the args + ;; then do the body + (if* (and args (atom args)) + then ; single arg + (return-from html-body-key-form + (case args + (:set (if* has-inv + then `(write-string ,(format nil "<~a>" string-code) + *html-stream*) + else `(write-string ,(format nil "<~a />" string-code) + *html-stream*))) + (:unset (if* has-inv + then `(write-string ,(format nil "" string-code) + *html-stream*))) + (t (error "illegal arg ~s to ~s" args string-code))))) + + (if* (not (evenp (length args))) + then (warn "arg list ~s isn't even" args)) + + + (if* args + then `(progn (write-string ,(format nil "<~a" string-code) + *html-stream*) + ,@(do ((xx args (cddr xx)) + (res)) + ((null xx) + (nreverse res)) + (if* (eq :if* (car xx)) + then ; insert following conditionally + (push `(if* ,(cadr xx) + then (write-string + ,(format nil " ~(~a~)" (caddr xx)) + *html-stream*) + (prin1-safe-http-string ,(cadddr xx))) + res) + (pop xx) (pop xx) + else + + (push `(write-string + ,(format nil " ~(~a~)" (car xx)) + *html-stream*) + res) + (push `(prin1-safe-http-string ,(cadr xx)) res))) + + ,(unless has-inv `(write-string " /" *html-stream*)) + (write-string ">" *html-stream*) + ,@body + ,(if* (and body has-inv) + then `(write-string ,(format nil "" string-code) + *html-stream*))) + else + (if* has-inv + then + `(progn (write-string ,(format nil "<~a>" string-code) + *html-stream*) + ,@body + ,(if* body + then `(write-string ,(format nil "" string-code) + *html-stream*))) + else + `(progn (write-string ,(format nil "<~a />" string-code) + *html-stream*))))) + + + +(defun princ-http (val) + ;; print the given value to the http stream using ~a + (format *html-stream* "~a" val)) + +(defun prin1-http (val) + ;; print the given value to the http stream using ~s + (format *html-stream* "~s" val)) + + +(defun princ-safe-http (val) + (emit-safe *html-stream* (format nil "~a" val))) + +(defun prin1-safe-http (val) + (emit-safe *html-stream* (format nil "~s" val))) + + +(defun prin1-safe-http-string (val) + ;; used only in a parameter value situation + ;; + ;; if the parameter value is the symbol with the empty print name + ;; then turn this into a singleton object. Thus || is differnent + ;; than "". + ;; + ;; print the contents inside a string double quotes (which should + ;; not be turned into "'s + ;; symbols are turned into their name + (if* (and (symbolp val) + (equal "" (symbol-name val))) + thenret ; do nothing + else (write-char #\= *html-stream*) + (if* (or (stringp val) + (and (symbolp val) + (setq val (string-downcase + (symbol-name val))))) + then (write-char #\" *html-stream*) + (emit-safe *html-stream* val) + (write-char #\" *html-stream*) + else (prin1-safe-http val)))) + + + +(defun emit-safe (stream string) + ;; send the string to the http response stream watching out for + ;; special html characters and encoding them appropriately + (do* ((i 0 (1+ i)) + (start i) + (end (length string))) + ((>= i end) + (if* (< start i) + then (write-sequence string + stream + :start start + :end i))) + + + (let ((ch (schar string i)) + (cvt )) + (if* (eql ch #\<) + then (setq cvt "<") + elseif (eq ch #\>) + then (setq cvt ">") + elseif (eq ch #\&) + then (setq cvt "&") + elseif (eq ch #\") + then (setq cvt """)) + (if* cvt + then ; must do a conversion, emit previous chars first + + (if* (< start i) + then (write-sequence string + stream + :start start + :end i)) + (write-string cvt stream) + + (setq start (1+ i)))))) + + + +(defun html-print-list (list-of-forms stream &key unknown) + ;; html print a list of forms + (dolist (x list-of-forms) + (html-print-subst x nil stream unknown))) + + +(defun html-print-list-subst (list-of-forms subst stream &key unknown) + ;; html print a list of forms + (dolist (x list-of-forms) + (html-print-subst x subst stream unknown))) + + +(defun html-print (form stream &key unknown) + (html-print-subst form nil stream unknown)) + + +(defun html-print-subst (form subst stream unknown) + ;; Print the given lhtml form to the given stream + (assert (streamp stream)) + + + (let* ((attrs) + (attr-name) + (name) + (possible-kwd (if* (atom form) + then form + elseif (consp (car form)) + then (setq attrs (cdar form)) + (caar form) + else (car form))) + print-handler + ent) + (if* (keywordp possible-kwd) + then (if* (null (setq ent (gethash possible-kwd *html-process-table*))) + then (if* unknown + then (return-from html-print-subst + (funcall unknown form stream)) + else (error "unknown html tag: ~s" possible-kwd)) + else ; see if we should subst + (if* (and subst + attrs + (setq attr-name (html-process-name-attr ent)) + (setq name (getf attrs attr-name)) + (setq attrs (html-find-value name subst))) + then + (return-from html-print-subst + (if* (functionp (cdr attrs)) + then + (funcall (cdr attrs) stream) + else (html-print-subst + (cdr attrs) + subst + stream + unknown))))) + + (setq print-handler + (html-process-print ent))) + (if* (atom form) + then (if* (keywordp form) + then (funcall print-handler ent :set nil nil nil nil stream) + elseif (stringp form) + then (write-string form stream) + else (princ form stream)) + elseif ent + then (funcall print-handler + ent + :full + (if* (consp (car form)) then (cdr (car form))) + form + subst + unknown + stream) + else (error "Illegal form: ~s" form)))) + + +(defun html-find-value (key subst) + ; find the (key . value) object in the subst list. + ; A subst list is an assoc list ((key . value) ....) + ; but instead of a (key . value) cons you may have an assoc list + ; + (let ((to-process nil) + (alist subst)) + (loop + (do* ((entlist alist (cdr entlist)) + (ent (car entlist) (car entlist))) + ((null entlist) (setq alist nil)) + (if* (consp (car ent)) + then ; this is another alist + (if* (cdr entlist) + then (push (cdr entlist) to-process)) + (setq alist ent) + (return) ; exit do* + elseif (equal key (car ent)) + then (return-from html-find-value ent))) + + (if* (null alist) + then ; we need to find a new alist to process + + (if* to-process + then (setq alist (pop to-process)) + else (return)))))) + +(defun html-standard-print (ent cmd args form subst unknown stream) + ;; the print handler for the normal html operators + (ecase cmd + (:set ; just turn it on + (format stream "<~a>" (html-process-key ent))) + (:full ; set, do body and then unset + (let (iter) + (if* args + then (if* (and (setq iter (getf args :iter)) + (setq iter (html-find-value iter subst))) + then ; remove the iter and pre + (setq args (copy-list args)) + (remf args :iter) + (funcall (cdr iter) + (cons (cons (caar form) + args) + (cdr form)) + subst + stream) + (return-from html-standard-print) + else + (format stream "<~a" (html-process-key ent)) + (do ((xx args (cddr xx))) + ((null xx)) + ; assume that the arg is already escaped + ; since we read it + ; from the parser + (format stream " ~a=\"~a\"" (car xx) (cadr xx))) + (format stream ">")) + else (format stream "<~a>" (html-process-key ent))) + (dolist (ff (cdr form)) + (html-print-subst ff subst stream unknown))) + (if* (html-process-has-inverse ent) + then ; end the form + (format stream "" (html-process-key ent)))))) + + + + + + + + +;; -- defining how html tags are handled. -- +;; +;; most tags are handled in a standard way and the def-std-html +;; macro is used to define such tags +;; +;; Some tags need special treatment and def-special-html defines +;; how these are handled. The tags requiring special treatment +;; are the pseudo tags we added to control operations +;; in the html generator. +;; +;; +;; tags can be found in three ways: +;; :br - singleton, no attributes, no body +;; (:b "foo") - no attributes but with a body +;; ((:a href="foo") "balh") - attributes and body +;; + + + +(defmacro def-special-html (kwd fcn print-fcn) + ;; kwd - the tag we're defining behavior for. + ;; fcn - function to compute the macroexpansion of a use of this + ;; tag. args to fcn are: + ;; ent - html-process object holding info on this tag + ;; args - list of attribute-values following tag + ;; argsp - true if there is a body in this use of the tag + ;; body - list of body forms. + ;; print-fcn - function to print an lhtml form with this tag + ;; args to fcn are: + ;; ent - html-process object holding info on this tag + ;; cmd - one of :set, :unset, :full + ;; args - list of attribute-value pairs + ;; subst - subsitution list + ;; unknown - function to call for unknown tags + ;; stream - stream to write to + ;; + `(setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd nil nil ,fcn ,print-fcn nil))) + + +(defmacro named-function (name &body body) + (declare (ignore name)) + `(function ,@body)) + + +(def-special-html :newline + (named-function html-newline-function + (lambda (ent args argsp body) + (declare (ignore ent args argsp)) + (if* body + then (error "can't have a body with :newline -- body is ~s" body)) + + `(terpri *html-stream*))) + + (named-function html-newline-print-function + (lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent unknown subst)) + (if* (eq cmd :set) + then (terpri stream) + else (error ":newline in an illegal place: ~s" form))))) + +(def-special-html :princ + (named-function html-princ-function + (lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-http ,bod)) + body)))) + + (named-function html-princ-print-function + (lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent unknown subst)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (format stream "~a" (cadr form)) + else (error ":princ must be given an argument"))))) + +(def-special-html :princ-safe + (named-function html-princ-safe-function + (lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(princ-safe-http ,bod)) + body)))) + (named-function html-princ-safe-print-function + (lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent unknown subst)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (emit-safe stream (format nil "~a" (cadr form))) + else (error ":princ-safe must be given an argument"))))) + +(def-special-html :prin1 + (named-function html-prin1-function + (lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-http ,bod)) + body)))) + (named-function html-prin1-print-function + (lambda (ent cmd args form subst unknown stream) + (declare (ignore ent args unknown subst)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (format stream "~s" (cadr form)) + else (error ":prin1 must be given an argument"))))) + +(def-special-html :prin1-safe + (named-function html-prin1-safe-function + (lambda (ent args argsp body) + (declare (ignore ent args argsp)) + `(progn ,@(mapcar #'(lambda (bod) + `(prin1-safe-http ,bod)) + body)))) + (named-function html-prin1-safe-print-function + (lambda (ent cmd args form subst unknown stream) + (declare (ignore args ent subst unknown)) + (assert (eql 2 (length form))) + (if* (eq cmd :full) + then (emit-safe stream (format nil "~s" (cadr form))) + else (error ":prin1-safe must be given an argument"))))) + +(def-special-html :comment + (named-function html-comment-function + (lambda (ent args argsp body) + ;; must use syntax + (declare (ignore ent args argsp)) + `(progn (write-string "" *html-stream*)))) + (named-function html-comment-print-function + (lambda (ent cmd args form subst unknown stream) + (declare (ignore ent cmd args subst unknown)) + (format stream "" (cadr form))))) + + + +(defmacro def-std-html (kwd has-inverse name-attrs) + (let ((mac-name (intern (format nil "~a-~a" :with-html kwd))) + (string-code (string-downcase (string kwd)))) + `(progn (setf (gethash ,kwd *html-process-table*) + (make-html-process ,kwd ,has-inverse + ',mac-name + nil + #'html-standard-print + ',name-attrs)) + (defmacro ,mac-name (args &rest body) + (html-body-key-form ,string-code ,has-inverse args body))))) + + + +(def-std-html :a t nil) +(def-std-html :abbr t nil) +(def-std-html :acronym t nil) +(def-std-html :address t nil) +(def-std-html :applet t nil) +(def-std-html :area nil nil) + +(def-std-html :b t nil) +(def-std-html :base nil nil) +(def-std-html :basefont nil nil) +(def-std-html :bdo t nil) +(def-std-html :bgsound nil nil) +(def-std-html :big t nil) +(def-std-html :blink t nil) +(def-std-html :blockquote t nil) +(def-std-html :body t nil) +(def-std-html :br nil nil) +(def-std-html :button nil nil) + +(def-std-html :caption t nil) +(def-std-html :center t nil) +(def-std-html :cite t nil) +(def-std-html :code t nil) +(def-std-html :col nil nil) +(def-std-html :colgroup nil nil) + +(def-std-html :dd t nil) +(def-std-html :del t nil) +(def-std-html :dfn t nil) +(def-std-html :dir t nil) +(def-std-html :div t nil) +(def-std-html :dl t nil) +(def-std-html :dt t nil) + +(def-std-html :em t nil) +(def-std-html :embed t nil) + +(def-std-html :fieldset t nil) +(def-std-html :font t nil) +(def-std-html :form t :name) +(def-std-html :frame t nil) +(def-std-html :frameset t nil) + +(def-std-html :h1 t nil) +(def-std-html :h2 t nil) +(def-std-html :h3 t nil) +(def-std-html :h4 t nil) +(def-std-html :h5 t nil) +(def-std-html :h6 t nil) +(def-std-html :head t nil) +(def-std-html :hr nil nil) +(def-std-html :html t nil) + +(def-std-html :i t nil) +(def-std-html :iframe t nil) +(def-std-html :ilayer t nil) +(def-std-html :img nil :id) +(def-std-html :input nil nil) +(def-std-html :ins t nil) +(def-std-html :isindex nil nil) + +(def-std-html :kbd t nil) +(def-std-html :keygen nil nil) + +(def-std-html :label t nil) +(def-std-html :layer t nil) +(def-std-html :legend t nil) +(def-std-html :li t nil) +(def-std-html :link nil nil) +(def-std-html :listing t nil) + +(def-std-html :map t nil) +(def-std-html :marquee t nil) +(def-std-html :menu t nil) +(def-std-html :meta nil nil) +(def-std-html :multicol t nil) + +(def-std-html :nobr t nil) +(def-std-html :noembed t nil) +(def-std-html :noframes t nil) +(def-std-html :noscript t nil) + +(def-std-html :object t nil) +(def-std-html :ol t nil) +(def-std-html :optgroup t nil) +(def-std-html :option t nil) + +(def-std-html :p t nil) +(def-std-html :param t nil) +(def-std-html :plaintext nil nil) +(def-std-html :pre t nil) + +(def-std-html :q t nil) + +(def-std-html :s t nil) +(def-std-html :samp t nil) +(def-std-html :script t nil) +(def-std-html :select t nil) +(def-std-html :server t nil) +(def-std-html :small t nil) +(def-std-html :spacer nil nil) +(def-std-html :span t :id) +(def-std-html :strike t nil) +(def-std-html :strong t nil) +(def-std-html :style t nil) +(def-std-html :sub t nil) +(def-std-html :sup t nil) + +(def-std-html :table t :name) +(def-std-html :tbody t nil) +(def-std-html :td t nil) +(def-std-html :textarea t nil) +(def-std-html :tfoot t nil) +(def-std-html :th t nil) +(def-std-html :thead t nil) +(def-std-html :title t nil) +(def-std-html :tr t nil) +(def-std-html :tt t nil) + +(def-std-html :u t nil) +(def-std-html :ul t nil) + +(def-std-html :var t nil) + +(def-std-html :wbr nil nil) + +(def-std-html :xmp t nil) + + + + +;;; KMR Local Additions + +(def-special-html :jscript + (named-function html-comment-function + (lambda (ent args argsp body) + ;; must use syntax + (declare (ignore ent args argsp)) + `(progn (write-string "" *html-stream*)))) + (named-function html-comment-print-function + (lambda (ent cmd args form subst unknown stream) + (declare (ignore ent cmd args subst unknown)) + (format stream "" + (cadr form))))) diff --git a/2/ifstar.lisp b/2/ifstar.lisp new file mode 100644 index 0000000..389451b --- /dev/null +++ b/2/ifstar.lisp @@ -0,0 +1,61 @@ +;;; -*- mode: common-lisp; package: lml2 -*- +;;; +;;; $Id: ifstar.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;; +;;; Public domain code by Franz + +(in-package #:lml2) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar if*-keyword-list '("then" "thenret" "else" "elseif"))) + +(defmacro if* (&rest args) + (do ((xx (reverse args) (cdr xx)) + (state :init) + (elseseen nil) + (totalcol nil) + (lookat nil nil) + (col nil)) + ((null xx) + (cond ((eq state :compl) + `(cond ,@totalcol)) + (t (error "if*: illegal form ~s" args)))) + (cond ((and (symbolp (car xx)) + (member (symbol-name (car xx)) + if*-keyword-list + :test #'string-equal)) + (setq lookat (symbol-name (car xx))))) + + (cond ((eq state :init) + (cond (lookat (cond ((string-equal lookat "thenret") + (setq col nil + state :then)) + (t (error + "if*: bad keyword ~a" lookat)))) + (t (setq state :col + col nil) + (push (car xx) col)))) + ((eq state :col) + (cond (lookat + (cond ((string-equal lookat "else") + (cond (elseseen + (error + "if*: multiples elses"))) + (setq elseseen t) + (setq state :init) + (push `(t ,@col) totalcol)) + ((string-equal lookat "then") + (setq state :then)) + (t (error "if*: bad keyword ~s" + lookat)))) + (t (push (car xx) col)))) + ((eq state :then) + (cond (lookat + (error + "if*: keyword ~s at the wrong place " (car xx))) + (t (setq state :compl) + (push `(,(car xx) ,@col) totalcol)))) + ((eq state :compl) + (cond ((not (string-equal lookat "elseif")) + (error "if*: missing elseif clause "))) + (setq state :init))))) diff --git a/2/lml2-tests.asd b/2/lml2-tests.asd new file mode 100644 index 0000000..50f18be --- /dev/null +++ b/2/lml2-tests.asd @@ -0,0 +1,26 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: lml2-tests.asd +;;;; Purpose: ASDF system definitionf for lml2 testing package +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id: lml2-tests.asd,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; ************************************************************************* + +(defpackage #:lml2-tests-system + (:use #:asdf #:cl)) +(in-package #:lml2-tests-system) + +(defsystem lml2-tests + :depends-on (:rt :lml2) + :components + ((:file "tests"))) + +(defmethod perform ((o test-op) (c (eql (find-system 'lml2-tests)))) + (or (funcall (intern (symbol-name '#:do-tests) + (find-package '#:regression-test))) + (error "test-op failed"))) + diff --git a/2/lml2.asd b/2/lml2.asd new file mode 100644 index 0000000..ae45570 --- /dev/null +++ b/2/lml2.asd @@ -0,0 +1,47 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: lml2.asd +;;;; Purpose: ASDF definition file for Lisp Markup Language Version 2 +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id: lml2.asd,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML2 users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:cl-user) +(defpackage #:lml2-system (:use #:asdf #:cl)) +(in-package #:lml2-system) + +(defsystem lml2 + :name "lml2" + :author "Kevin M. Rosenberg " + :version "1.0" + :maintainer "Kevin M. Rosenberg " + :licence "GNU General Public License" + :description "Lisp Markup Language" + :long-description "LML2 provides creation of XHTML for Lisp programs." + + :components + ((:file "package") + (:file "ifstar" :depends-on ("package")) + (:file "data" :depends-on ("package")) + (:file "htmlgen" :depends-on ("ifstar" "data")) + (:file "utils" :depends-on ("package")) + (:file "files" :depends-on ("utils" "htmlgen")) + (:file "base" :depends-on ("files")) + (:file "read-macro" :depends-on ("base")) + (:file "stdsite" :depends-on ("base")) + (:file "downloads" :depends-on ("base")) + )) + +(defmethod perform ((o test-op) (c (eql (find-system 'lml2)))) + (operate 'load-op 'lml2-tests) + (operate 'test-op 'lml2-tests)) diff --git a/2/package.lisp b/2/package.lisp new file mode 100644 index 0000000..db700bc --- /dev/null +++ b/2/package.lisp @@ -0,0 +1,65 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: package.lisp +;;;; Purpose: Package file for Lisp Markup Language 2 +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: June 2003 +;;;; +;;;; $Id: package.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML2 users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:cl-user) + +(defpackage #:lisp-markup-language-2 + (:use #:common-lisp) + (:nicknames #:lml2) + (:export + + ;; base.lisp + #:*print-spaces* + #:reset-indent + #:with + #:print-page + #:page + #:lml-format + #:lml-print + #:lml-princ + #:lml-write-char + #:lml-write-string + #:lml-print-date + #:*html-output* + + ;; htmlgen.lisp + #:html #:html-print #:html-print-subst #:html-print-list #:html-print-list-subst + #:html-stream #:*html-stream* + + + ;; files.lisp + #:with-dir + #:process-dir + #:lml-load + #:include-file + + ;; stdsite.lisp + #:print-std-page + #:std-page + #:std-body + #:std-head + #:titled-pre-section + + ;; downloads.lisp + #:std-dl-page + #:full-dl-page + + ;; utils.lisp + #:lml-quit + #:lml-cwd +)) diff --git a/2/read-macro.lisp b/2/read-macro.lisp new file mode 100644 index 0000000..16dc05d --- /dev/null +++ b/2/read-macro.lisp @@ -0,0 +1,82 @@ +;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: read-macro.lisp +;;;; Purpose: Lisp Markup Language functions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id: read-macro.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML2 users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +(in-package #:lml2) + +(defun new-string () + (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character)) + +(set-macro-character #\[ + #'(lambda (stream char) + (declare (ignore char)) + (let ((forms '()) + (curr-string (new-string)) + (paren-level 0) + (got-comma nil)) + (declare (type fixnum paren-level)) + (do ((ch (read-char stream t nil t) (read-char stream t nil t))) + ((eql ch #\])) + (if got-comma + (if (eql ch #\() + ;; Starting top-level ,( + (progn + #+cmu + (setf curr-string (coerce curr-string `(simple-array character (*)))) + + (push `(lml2-princ ,curr-string) forms) + (setq curr-string (new-string)) + (setq got-comma nil) + (vector-push #\( curr-string) + (do ((ch (read-char stream t nil t) (read-char stream t nil t))) + ((and (eql ch #\)) (zerop paren-level))) + (when (eql ch #\]) + (format *trace-output* "Syntax error reading #\]") + (return nil)) + (case ch + (#\( + (incf paren-level)) + (#\) + (decf paren-level))) + (vector-push-extend ch curr-string)) + (vector-push-extend #\) curr-string) + (let ((eval-string (read-from-string curr-string)) + (res (gensym))) + (push + `(let ((,res ,eval-string)) + (when ,res + (lml2-princ ,res))) + forms)) + (setq curr-string (new-string))) + ;; read comma, then non #\( char + (progn + (unless (eql ch #\,) + (setq got-comma nil)) + (vector-push-extend #\, curr-string) ;; push previous command + (vector-push-extend ch curr-string))) + ;; previous character is not a comma + (if (eql ch #\,) + (setq got-comma t) + (progn + (setq got-comma nil) + (vector-push-extend ch curr-string))))) + + #+cmu + (setf curr-string (coerce curr-string `(simple-array character (*)))) + + (push `(lml2-princ ,curr-string) forms) + `(progn ,@(nreverse forms))))) diff --git a/2/stdsite.lisp b/2/stdsite.lisp new file mode 100644 index 0000000..bf7773b --- /dev/null +++ b/2/stdsite.lisp @@ -0,0 +1,89 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: stdsite.lisp +;;;; Purpose: Functions to create my standard style sites +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id: stdsite.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML2 users are granted the rights to distribute and use this software +;;;; as governed by the terms of the GNU General Public License v2 +;;;; (http://www.gnu.org/licenses/gpl.html) +;;;; ************************************************************************* + +;;; A "standard site" is a format for a certain style of web page. +;;; It is based on the LML2 package. +;;; A stdsite page expects to include the following files: +;;; head.lml_ +;;; banner.lml_ +;;; content.lml_ +;;; footer.lml_ + +(in-package #:lml2) + +(defmacro std-head (title &body body) + `(html + (:head + (:title (:princ ,title)) + (lml-load "head.lml_") + ,@body))) + + +(defun std-footer (file) + (html + ((:div :class "disclaimsec") + (let ((src-file (make-pathname + :defaults *sources-dir* + :type "lml" + :name (pathname-name file)))) + (when (probe-file src-file) + (html + ((:div :class "lastmod") + (lml-format "Last modified: ~A" (date-string (file-write-date src-file))))))) + (when (probe-file "footer.lml_") + (lml-load "footer.lml_"))))) + + +(defmacro std-body (file &body body) + `(body + (lml-load "banner.lml_") + (html + ((:table :class "stdbodytable" :border "0" :cellpadding "3") + (:tbody + ((:tr :valign "top") + ((td :class "stdcontentcell") + (lml-load "contents.lml_")) + ((:td :valign "top") + ,@body + (std-footer ,file)))))))) + + +(defmacro print-std-page (file title &body body) + `(progn + (xhtml-prologue) + (html + ((:html :xmlns "http://www.w3.org/1999/xhtml") + (std-head ,title) + (std-body ,file ,@body))))) + +(defmacro std-page (out-file title &body body) + `(let ((*indent* 0)) + (with-open-file (*html-stream* (lml-file-name ,out-file :output) + :direction :output + :if-exists :supersede) + (print-std-page (lml-file-name ,out-file :source) ,title ,@body)))) + +(defmacro titled-pre-section (title &body body) + `(progn + (html + (:h1 ,title) + ((:pre "style" "padding-left:30pt;") + ,@body)))) + + + diff --git a/2/tests.lisp b/2/tests.lisp new file mode 100644 index 0000000..fca7c27 --- /dev/null +++ b/2/tests.lisp @@ -0,0 +1,69 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: lml-tests.lisp +;;;; Purpose: lml tests file +;;;; Author: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id: tests.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; This file is Copyright (c) 2000-2002 by Kevin M. Rosenberg +;;;; +;;;; ************************************************************************* + +(in-package #:cl) +(defpackage #:lml-tests + (:use #:lml #:cl #:rtest)) +(in-package #:lml-tests) + +(rem-all-tests) + +(deftest lml.0 + (with-output-to-string (s) + (let ((*html-output* s)) + (div))) + "
") + +(deftest lml.1 + (with-output-to-string (s) + (let ((*html-output* s)) + (span-c foo "Foo Bar"))) + "Foo Bar") + +(deftest lml.2 + (with-output-to-string (s) + (let ((*html-output* s)) + (table-c foo :style "width:80%" "Foo" " Bar" " test"))) + "Foo Bar test
") + +(deftest lml.3 + (with-output-to-string (s) + (let ((*html-output* s) + (a 5.5d0)) + (p a))) + "

5.5d0

") + +(deftest lml.4 + (with-output-to-string (s) + (let ((*html-output* s) + (a 0.75)) + (img "http://localhost/test.png" :width a))) + "") + +(deftest lml.5 + (with-output-to-string (s) + (let ((*html-output* s)) + (div "Start" + (p "Testing")))) + "
Start

Testing

") + +(deftest lml.6 + (with-output-to-string (s) + (let ((*html-output* s)) + (div :style "font-weight:bold" + "Start" + (p-c a_class "Testing")))) + "
Start

Testing

") + diff --git a/2/utils.lisp b/2/utils.lisp new file mode 100644 index 0000000..20f6a45 --- /dev/null +++ b/2/utils.lisp @@ -0,0 +1,82 @@ +;;; $Id: utils.lisp,v 1.1 2003/06/20 04:12:29 kevin Exp $ +;;;; +;;;; General purpose utilities + +(in-package #:lml2) + +(defmacro aif (test then &optional else) + `(let ((it ,test)) + (if it ,then ,else))) + +(defmacro awhen (test-form &body body) + `(aif ,test-form + (progn ,@body))) + +(defun keyword-symbol? (x) + "Returns T if object is a symbol in the keyword package" + (and (symbolp x) + (string-equal "keyword" (package-name (symbol-package x))))) + +(defun list-to-spaced-string (list) + (format nil "~{~A~^ ~}" list)) + +(defun print-n-chars (char n stream) + (declare (fixnum n) + (optimize (speed 3) (safety 0) (space 0))) + (do ((i 0 (1+ i))) + ((= i n) char) + (declare (fixnum i)) + (write-char char stream))) + +(defun indent-spaces (n &optional (stream *standard-output*)) + "Indent n*2 spaces to output stream" + (print-n-chars #\space (+ n n) stream)) + +(defun print-file-contents (file &optional (strm *standard-output*)) + "Opens a reads a file. Returns the contents as a single string" + (when (probe-file file) + (with-open-file (in file :direction :input) + (do ((line (read-line in nil 'eof) + (read-line in nil 'eof))) + ((eql line 'eof)) + (write-string line strm) + (write-char #\newline strm))))) + +(defun date-string (ut) + (check-type ut integer) + (multiple-value-bind (sec min hr day mon year dow daylight-p zone) + (decode-universal-time ut) + (declare (ignore daylight-p zone)) + (format nil "~[Mon~;Tue~;Wed~;Thu~;Fri~;Sat~;Sun~], ~d ~[Jan~;Feb~;Mar~;Apr~;May~;Jun~;Jul~;Aug~;Sep~;Oct~;Nov~;Dec~] ~d ~2,'0d:~2,'0d:~2,'0d" + dow day (1- mon) year hr min sec))) + +(defun lml-quit (&optional (code 0)) + "Function to exit the Lisp implementation." + #+allegro (excl:exit code) + #+clisp (#+lisp=cl ext:quit #-lisp=cl lisp:quit code) + #+(or cmu scl) (ext:quit code) + #+cormanlisp (win32:exitprocess code) + #+gcl (lisp:bye code) + #+lispworks (lw:quit :status code) + #+lucid (lcl:quit code) + #+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1))) + #+openmcl (ccl:quit code) + #+(and mcl (not openmcl)) (declare (ignore code)) + #+(and mcl (not openmcl)) (ccl:quit) + #-(or allegro clisp cmu scl cormanlisp gcl lispworks lucid sbcl mcl) + (error 'not-implemented :proc (list 'quit code))) + + +(defun lml-cwd () + "Returns the current working directory. Based on CLOCC's DEFAULT-DIRECTORY function." + #+allegro (excl:current-directory) + #+clisp (#+lisp=cl ext:default-directory #-lisp=cl lisp:default-directory) + #+(or cmu scl) (ext:default-directory) + #+cormanlisp (ccl:get-current-directory) + #+lispworks (hcl:get-working-directory) + #+lucid (lcl:working-directory) + #+sbcl (sb-unix:posix-getcwd/) + #+mcl (ccl:mac-default-directory) + #-(or allegro clisp cmu scl sbcl cormanlisp lispworks lucid mcl) (truename ".")) + + -- 2.34.1