cl-lml-2.5.7/0000755000175000017500000000000010671111144011713 5ustar kevinkevincl-lml-2.5.7/api.lisp0000644000175000017500000001044710667175457013411 0ustar kevinkevin;;;; -*- 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$ ;;;; ;;;; 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)))) cl-lml-2.5.7/doc/0000755000175000017500000000000010667175457012506 5ustar kevinkevincl-lml-2.5.7/doc/Makefile0000644000175000017500000000015610667175457014150 0ustar kevinkevin.PHONY: site all clean all: site site: sbcl --load `pwd`/make.lisp clean: @rm -f *~ \#*\# .\#* memdump cl-lml-2.5.7/doc/make.lisp0000644000175000017500000000024010667175457014310 0ustar kevinkevin#+cmu (setq ext:*gc-verbose* nil) (asdf:operate 'asdf:load-op 'lml) (in-package lml) (let ((cwd (parse-namestring (lml-cwd)))) (process-dir cwd)) (lml-quit) cl-lml-2.5.7/doc/readme.html0000644000175000017500000000431410671111143014604 0ustar kevinkevin 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 either ASDF or mk-defsystem 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
(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.

cl-lml-2.5.7/doc/readme.lml0000644000175000017500000000431510667175457014454 0ustar kevinkevin;;; -*- Mode: Lisp -*- (in-package :lml) (page readme (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 either ,(a :href "http://cclan.sourceforge.net/" "ASDF") or ,(a :href "http://www.sourceforge.net/clocc/" "mk-defsystem") 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 "(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").]) )) cl-lml-2.5.7/files.lisp0000644000175000017500000000543110667175457013737 0ustar kevinkevin;;;; -*- 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) ;;;; ************************************************************************* (in-package #:lml) (eval-when (:compile-toplevel :load-toplevel :execute) (defvar *output-dir* nil) (defvar *sources-dir* nil) ) (defvar *html-output* *standard-output*) (defun lml-file-name (f &optional (type :source)) (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) (nth-value 0 (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-output*)) cl-lml-2.5.7/lml-tests.asd0000644000175000017500000000144410667175457014361 0ustar kevinkevin;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: lml-tests.asd ;;;; Purpose: ASDF system definitionf for lml testing package ;;;; Author: Kevin M. Rosenberg ;;;; Date Started: Apr 2003 ;;;; ;;;; $Id$ ;;;; ************************************************************************* (defpackage #:lml-tests-system (:use #:asdf #:cl)) (in-package #:lml-tests-system) (defsystem lml-tests :depends-on (:rt :lml) :components ((:file "tests"))) (defmethod perform ((o test-op) (c (eql (find-system 'lml-tests)))) (or (funcall (intern (symbol-name '#:do-tests) (find-package '#:regression-test))) (error "test-op failed"))) cl-lml-2.5.7/lml.asd0000644000175000017500000000275510667175457013227 0ustar kevinkevin;;;; -*- 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$ ;;;; ;;;; 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 #:lml-system (:use #:asdf #:cl)) (in-package #:lml-system) (defsystem lml :name "lml" :author "Kevin M. Rosenberg " :version "2.4" :maintainer "Kevin M. Rosenberg " :licence "GNU General Public License" :description "Lisp Markup Language" :long-description "LML provides creation of XHTML for Lisp programs." :components ((:file "package") (:file "utils" :depends-on ("package")) (:file "files" :depends-on ("utils")) (: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 'lml)))) (operate 'load-op 'lml-tests) (operate 'test-op 'lml-tests)) cl-lml-2.5.7/package.lisp0000644000175000017500000000244110667175457014226 0ustar kevinkevin;;;; -*- 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$ ;;;; ;;;; 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 (:use #:common-lisp) (:nicknames #:lml) (: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* ;; 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 )) cl-lml-2.5.7/read-macro.lisp0000644000175000017500000000611610667175457014650 0ustar kevinkevin;;; -*- 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$ ;;;; ;;;; 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 #:lml) (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 `(lml-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 (lml-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 `(lml-princ ,curr-string) forms) `(progn ,@(nreverse forms))))) cl-lml-2.5.7/stdsite.lisp0000644000175000017500000000472310667175457014317 0ustar kevinkevin;;;; -*- 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$ ;;;; ;;;; 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_ (in-package #:lml) (defmacro std-head (title &body body) `(head (title ,title) (lml-load "head.lml_") ,@body)) (defun std-footer (file) (div-c "disclaimsec" (let ((src-file (make-pathname :defaults *sources-dir* :type "lml" :name (pathname-name file)))) (when (probe-file src-file) (div-c "lastmod" (lml-format "Last modified: ~A" (date-string (file-write-date src-file)))))) (lml-load "footer.lml_")) (values)) (defmacro std-body (file &body body) `(body (lml-load "banner.lml_") (table-c "stdbodytable" :border "0" :cellpadding "3" (tbody (tr :valign "top" (td-c "stdcontentcell" (lml-load "contents.lml_")) (td :valign "top" ,@body (std-footer ,file))))) (lml-load "final.lml_"))) (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))) cl-lml-2.5.7/tests.lisp0000644000175000017500000000336510667175457014003 0ustar kevinkevin;;;; -*- 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$ ;;;; ;;;; 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

") cl-lml-2.5.7/utils.lisp0000644000175000017500000000553110667175457013776 0ustar kevinkevin;;; $Id$ ;;;; ;;;; 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 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 ".")) cl-lml-2.5.7/downloads.lisp0000644000175000017500000001520610667714130014613 0ustar kevinkevin;;;; -*- 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$ ;;;; ;;;; 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 #:lml) (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)) (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 giturl gitweb 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) (when giturl (lml-format "

Git Repository

~A" giturl) (when gitweb (lml-format "  [Browse]" gitweb))) (display-footer))) (defun std-dl-page (pkg-name pkg-base dl-base dl-url &optional giturl gitweb) (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 giturl gitweb `(("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 &optional giturl gitweb) (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 giturl gitweb `(("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)))))))) cl-lml-2.5.7/base.lisp0000644000175000017500000002002710671111125013516 0ustar kevinkevin;;; -*- 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$ ;;;; ;;;; 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 #:lml) (defun html4-prologue-string () "") (defun xml-prologue-string () "") (defun xhtml-prologue-string () "") (defvar *print-spaces* nil) (defvar *indent* 0) (defun reset-indent () (setq *indent* 0)) (defun lml-format (str &rest args) (when (streamp *html-output*) (when *print-spaces* (indent-spaces *indent* *html-output*)) (if args (apply #'format *html-output* str args) (write-string str *html-output*)) (when *print-spaces* (write-char #\newline *html-output*)))) (defun lml-princ (s) (princ s *html-output*)) (defun lml-print (s) (format *html-output* "~A~%" s)) (defun lml-write-char (char) (write-char char *html-output*)) (defun lml-write-string (str) (write-string str *html-output*)) (defun lml-print-date (date) (lml-write-string (date-string date))) (defmacro lml-exec-body (&body forms) `(progn ,@(mapcar #'(lambda (form) (etypecase form (string `(lml-princ ,form)) (number `(lml-format "~D" ,form)) (symbol (when form `(lml-princ ,form))) (cons form))) forms))) (defmacro with-attr-string (tag attr-string &body body) (let ((attr (gensym))) `(let ((,attr ,attr-string)) (lml-format "<~(~A~)~A>" ',tag (if (and (stringp ,attr) (plusp (length ,attr))) (format nil " ~A" ,attr) "")) (incf *indent*) (lml-exec-body ,@body) (decf *indent*) (lml-format "" ',tag)))) (defmacro with-no-endtag-attr-string (tag attr-string) (let ((attr (gensym))) `(let ((,attr ,attr-string)) (lml-format "<~(~A~)~A />" ',tag (if (and (stringp ,attr) (plusp (length ,attr))) (format nil " ~A" ,attr) ""))))) (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 (cdr ,kv) (push (one-keyarg-string (car ,kv) it) ,attr))) (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body))))) (defmacro with-no-endtag-keyargs (tag keyargs) (let ((attr (gensym)) (kv (gensym))) `(progn (let ((,attr '())) (dolist (,kv ,keyargs) (awhen (cdr ,kv) (push (one-keyarg-string (car ,kv) it) ,attr))) (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr))))))) (defmacro bind-one-keyarg (keyarg) `(list ,(car keyarg) ,(cdr keyarg))) (defmacro bind-all-keyargs (keyargs) "Convert a list of keyarg pairs and convert eval/bind arguments" (let* ((npairs (length keyargs)) (syms (make-array npairs)) (ipair 0) (ipair2 0)) (declare (dynamic-extent syms)) (dotimes (i npairs) (setf (aref syms i) (gensym))) `(let ,(mapcar #'(lambda (ka) (prog1 (list (aref syms ipair) (cdr ka)) (incf ipair))) keyargs) (list ,@(mapcar #'(lambda (ka) (prog1 `(cons ,(car ka) ,(aref syms ipair2)) (incf ipair2))) keyargs))))) (defmacro with (tag &rest args) "Return a list of keyargs and also the body of LML form" (let ((body '()) (keyargs '()) (bound-keyargs (gensym))) (do* ((n (length args)) (i 0 (+ 2 i)) (arg (nth i args) (nth i args)) (value (when (< (1+ i) n) (nth (1+ i) args)) (when (< (1+ i) n) (nth (1+ i) args)))) ((or (not (keyword-symbol? arg)) (>= i n)) (dotimes (j (- n i)) (push (nth (+ i j) args) body))) (push (cons arg value) keyargs)) (setq keyargs (nreverse keyargs)) (setq body (nreverse body)) `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs)))) ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body))))) (defmacro with-no-endtag (tag &rest args) "Return a list of keyargs body of LML form" (let ((keyargs '()) (bound-keyargs (gensym))) (do* ((n (length args)) (i 0 (+ 2 i)) (arg (nth i args) (nth i args)) (value (when (< (1+ i) n) (nth (1+ i) args)) (when (< (1+ i) n) (nth (1+ i) args)))) ((or (not (keyword-symbol? arg)) (>= i n))) (push (cons arg value) keyargs)) (setq keyargs (nreverse keyargs)) `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs)))) ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs))))) (defmacro jscript (&body body) `(with script :language "JavaScript" :type "text/javascript" ,@body)) (defmacro xhtml-prologue () `(progn (lml-format "~A~%" (xml-prologue-string)) (lml-format "~A~%" (xhtml-prologue-string)))) (defmacro alink (dest &body body) `(with a :href ,dest ,@body)) (defmacro alink-c (class dest &body body) `(with a :href ,dest :class (quote ,class) ,@body)) (defmacro img (dest &rest args) `(with-no-endtag img :src ,dest ,@args)) (defmacro input (&rest args) `(with-no-endtag input ,@args)) (defmacro link (&rest args) `(with-no-endtag link ,@args)) (defmacro meta (&rest args) `(with-no-endtag meta ,@args)) (defmacro br (&rest args) `(with-no-endtag br ,@args)) (defmacro hr (&rest args) `(with-no-endtag hr ,@args)) (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 (quote ,(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 th tr body head html title pre tt u dl dt dd kbd code form textarea blockquote var strong small samp big cite address dfn em q area del ins object param caption col colgroup script noscript)) (export '(jscript alink alink-c br hr img input meta link 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))) (defun new-string () (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))