From 91da637a38b3a1f38d0bf25b2e3584b80400664f Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 3 Feb 2004 18:17:32 +0000 Subject: [PATCH] r8592: add apache-dir module --- apache-dir.lisp | 188 +++++++++++++++++++++++++++++++++++++++++++++++ debian/changelog | 6 ++ lml2.asd | 1 + package.lisp | 3 + 4 files changed, 198 insertions(+) create mode 100644 apache-dir.lisp diff --git a/apache-dir.lisp b/apache-dir.lisp new file mode 100644 index 0000000..0791fac --- /dev/null +++ b/apache-dir.lisp @@ -0,0 +1,188 @@ +;;;; -*- 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 + "" + :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 "
") + :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 "
") + :newline + (when address + (html-stream + stream + (:address address)))))))) + diff --git a/debian/changelog b/debian/changelog index fd65d05..0d29d22 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-lml2 (1.5.0-1) unstable; urgency=low + + * New upstream with apache-dir module + + -- Kevin M. Rosenberg Tue, 3 Feb 2004 11:14:59 -0700 + cl-lml2 (1.4.2-1) unstable; urgency=low * Add entities keyword to doctype output diff --git a/lml2.asd b/lml2.asd index 9f4cfbf..d40d7fd 100644 --- a/lml2.asd +++ b/lml2.asd @@ -39,6 +39,7 @@ #+ignore (:file "read-macro" :depends-on ("base")) (:file "stdsite" :depends-on ("base")) (:file "downloads" :depends-on ("base")) + (:file "apache-dir" :depends-on ("base")) )) (defmethod perform ((o test-op) (c (eql (find-system 'lml2)))) diff --git a/package.lisp b/package.lisp index 51a515c..e7bd839 100644 --- a/package.lisp +++ b/package.lisp @@ -61,4 +61,7 @@ ;; utils.lisp #:lml-quit #:lml-cwd + + ;; apache-dir + #:write-html-apache-directory )) -- 2.34.1