;;;; -*- 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 universal-time-to-apache-date (utime) (multiple-value-bind (second minute hour day-of-month month year day-of-week daylight-p zone) (decode-universal-time utime) (declare (ignore second day-of-week daylight-p zone)) (format nil (formatter "~2,'0D-~3/kmrcl::monthname/-~4,'0D ~2,'0D:~2,'0D") day-of-month month year hour minute))) (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))))))))