+++ /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 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
- "<!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 / lml.git / blobdiff