--- /dev/null
+;;;; -*- 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 7061 2003-09-07 06:34:45Z kevin $
+;;;;
+;;;; 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)
+
+(defparameter *apache-name-width* 24)
+
+(defun write-name-trailing-spaces (stream name)
+ (let* ((spaces (- *apache-name-width* (length name))))
+ (when (plusp spaces)
+ (print-n-chars #\space spaces stream))))
+
+(defun write-name-link (stream link name)
+ (html-stream
+ stream
+ ((:a :href link) (:princ (string-maybe-shorten name *apache-name-width*))))
+ (write-name-trailing-spaces stream name))
+
+(defun sort-dir-entries (entries sort-field direct)
+ (case sort-field
+ (:name
+ (sort entries
+ (lambda (a b)
+ (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
+ (aif (third a) it "")
+ (aif (third b) it "")))))
+ (:modified
+ (sort entries
+ (lambda (a b)
+ (funcall (if (eq direct :asc) #'< #'>)
+ (aif (fourth a) it 0)
+ (aif (fourth b) it 0)))))
+ (:size
+ (sort entries
+ (lambda (a b)
+ (funcall (if (eq direct :asc) #'< #'>)
+ (aif (fifth a) it 0)
+ (aif (fifth b) it 0)))))
+ (:description
+ (sort entries
+ (lambda (a b)
+ (funcall (if (eq direct :asc) #'string-lessp #'string-greaterp)
+ (aif (sixth a) it "")
+ (aif (sixth b) it "")))))
+ (t
+ entries)))
+
+(defun write-html-apache-directory (stream title entries this-url &key parent address query-string
+ icon-base)
+ (let* ((query (when query-string (split-uri-query-string query-string)))
+ (sort-field (if query
+ (cond
+ ((string-equal (caar query) "N") :name)
+ ((string-equal (caar query) "M") :modified)
+ ((string-equal (caar query) "S") :size)
+ ((string-equal (caar query) "D") :description)
+ (t :name))
+ :name))
+ (dir (cond
+ ((and query (string-equal (cdr (first query)) "D") :desc))
+ (t :asc))))
+ (setq entries (sort-dir-entries entries sort-field dir))
+
+ (html-stream
+ stream
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" \"http://www.w3.org/TR/REC-html40/loose.dtd\">"
+ :newline
+ (:html
+ :newline
+ (:head
+ :newline
+ (:title (:princ title)))
+ :newline
+ ((:body :bgcolor "#FFFFFF" :text "#000000")
+ :newline
+ (:table
+ (:tr
+ ((:td :bgcolor "#FFFFFF" :class "title")
+ ((:font :size "+3" :face "Hevetica,Arial,sans-serif")
+ (:b (:princ title))))))
+ :newline
+ (:pre
+ (when icon-base
+ (html-stream
+ stream
+ ((:img :border "0"
+ :src (format nil "~Ablank.png" icon-base)
+ :alt " "))))
+ " "
+ ((:a :href (format nil "~A?N=~A" this-url
+ (if (and (eq sort-field :name) (eq dir :asc))
+ "D" "A")))
+ "Name")
+ (:princ (format nil "~20A" ""))
+ " "
+ ((:a :href (format nil "~A?M=~A" this-url
+ (if (and (eq sort-field :modified) (eq dir :asc))
+ "D" "A")))
+ "Last modified")
+ " "
+ ((:a :href (format nil "~A?S=~A" this-url
+ (if (and (eq sort-field :size) (eq dir :asc))
+ "D" "A")))
+ "Size")
+ " "
+ ((:a :href (format nil "~A?D=~A" this-url
+ (if (and (eq sort-field :description) (eq dir :asc))
+ "D" "A")))
+ "Description")
+ :newline
+ (:princ "<hr noshade align=\"left\" width=\"80%\">")
+ :newline
+ (when parent
+ (html-stream
+ stream
+ (when icon-base
+ (html-stream
+ stream
+ ((:img :border "0"
+ :src (format nil "~Aback.png" icon-base
+ :alt "[DIR]")))))
+ " "
+ (write-name-link stream (first parent) (second parent))
+ " "
+ (print-n-chars #\space 17 stream)
+ " -"
+ :newline))
+ (dolist (entry entries)
+ (html-stream
+ stream
+ (when icon-base
+ (html-stream
+ stream
+ ((:img :border "0"
+ :src
+ (case (car entry)
+ (:dir (format nil "~Afolder.png" icon-base))
+ (:text (format nil "~Atext.png" icon-base))
+ (t (format nil "~Af.png" icon-base))]
+ :alt
+ (case (car entry)
+ (:dir "[DIR]")
+ (:text "[TXT]")
+ (t "[FIL]"))))))
+ " "
+ (write-name-link stream (second entry) (third entry))
+ " "
+ (:princ (universal-time-to-apache-date (fourth entry)))
+ (:princ
+ (cond
+ ((or (eq :dir (first entry))
+ (null (fifth entry)))
+ " -")
+ ((< (fifth entry) (* 1024 1024))
+ (format nil "~5,' Dk" (round (fifth entry) 1024)))
+ ((< (fifth entry) (* 1024 1024 1024))
+ (format nil "~5,' Dm" (round (fifth entry) (* 1024 1024))))
+ (t
+ (format nil "~5,' Dg" (round (fifth entry) (* 1024 1024 1024))))
+ ))
+ " "
+ (:princ
+ (if (sixth entry)
+ (sixth entry)
+ ""))
+ :newline)))
+ (:princ "<hr noshade align=\"left\" width=\"80%\">")
+ :newline
+ (when address
+ (html-stream
+ stream
+ (:address address))))))))
+
projects / lml2.git / commitdiff