1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: ASDF definition file for Lisp Markup Language Version 2
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Aug 2002
10 ;;;; $Id: lml2.asd 7061 2003-09-07 06:34:45Z kevin $
12 ;;;; This file, part of LML2, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; LML2 users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the GNU General Public License v2
16 ;;;; (http://www.gnu.org/licenses/gpl.html)
17 ;;;; *************************************************************************
21 (defparameter *apache-name-width* 24)
23 (defun write-name-trailing-spaces (stream name)
24 (let* ((spaces (- *apache-name-width* (length name))))
26 (print-n-chars #\space spaces stream))))
28 (defun write-name-link (stream link name)
31 ((:a :href link) (:princ (string-maybe-shorten name *apache-name-width*))))
32 (write-name-trailing-spaces stream name))
34 (defun universal-time-to-apache-date (utime)
36 (second minute hour day-of-month month year day-of-week daylight-p zone)
37 (decode-universal-time utime)
38 (declare (ignore second day-of-week daylight-p zone))
40 (formatter "~2,'0D-~3/kmrcl::monthname/-~4,'0D ~2,'0D:~2,'0D")
41 day-of-month month year hour minute)))
43 (defun sort-dir-entries (entries sort-field direct)
48 (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
50 (aif (third b) it "")))))
54 (funcall (if (eq direct :asc) #'< #'>)
56 (aif (fourth b) it 0)))))
60 (funcall (if (eq direct :asc) #'< #'>)
62 (aif (fifth b) it 0)))))
66 (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
68 (aif (sixth b) it "")))))
72 (defun write-html-apache-directory (stream title entries this-url &key parent address query-string
74 (let* ((query (when query-string (split-uri-query-string query-string)))
77 ((string-equal (caar query) "N") :name)
78 ((string-equal (caar query) "M") :modified)
79 ((string-equal (caar query) "S") :size)
80 ((string-equal (caar query) "D") :description)
84 ((and query (string-equal (cdr (first query)) "D") :desc))
86 (setq entries (sort-dir-entries entries sort-field dir))
90 "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">"
96 (:title (:princ title)))
98 ((:body :bgcolor "#FFFFFF" :text "#000000")
102 ((:td :bgcolor "#FFFFFF" :class "title")
103 ((:font :size "+3" :face "Hevetica,Arial,sans-serif")
104 (:b (:princ title))))))
111 :src (format nil "~Ablank.png" icon-base)
114 ((:a :href (format nil "~A?N=~A" this-url
115 (if (and (eq sort-field :name) (eq dir :asc))
118 (:princ (format nil "~20A" ""))
120 ((:a :href (format nil "~A?M=~A" this-url
121 (if (and (eq sort-field :modified) (eq dir :asc))
125 ((:a :href (format nil "~A?S=~A" this-url
126 (if (and (eq sort-field :size) (eq dir :asc))
130 ((:a :href (format nil "~A?D=~A" this-url
131 (if (and (eq sort-field :description) (eq dir :asc))
135 (:princ "<hr noshade align=\"left\" width=\"80%\">")
144 :src (format nil "~Aback.png" icon-base
147 (write-name-link stream (first parent) (second parent))
149 (print-n-chars #\space 17 stream)
152 (dolist (entry entries)
161 (:dir (format nil "~Afolder.png" icon-base))
162 (:text (format nil "~Atext.png" icon-base))
163 (t (format nil "~Af.png" icon-base)))
170 (write-name-link stream (second entry) (third entry))
172 (:princ (universal-time-to-apache-date (fourth entry)))
175 ((or (eq :dir (first entry))
176 (null (fifth entry)))
178 ((< (fifth entry) (* 1024 1024))
179 (format nil "~5,' Dk" (round (fifth entry) 1024)))
180 ((< (fifth entry) (* 1024 1024 1024))
181 (format nil "~5,' Dm" (round (fifth entry) (* 1024 1024))))
183 (format nil "~5,' Dg" (round (fifth entry) (* 1024 1024 1024))))
191 (:princ "<hr noshade align=\"left\" width=\"80%\">")
196 (:address address))))))))