X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=downloads.lisp;fp=downloads.lisp;h=226095eebfa7d3bf0ea21fe208f9f3534498f465;hb=e741d288978f9a65554235ecb3115db8eef60b54;hp=0000000000000000000000000000000000000000;hpb=f3088cd6e99688e7bc3d37bb6c5a58e08c958611;p=lml.git diff --git a/downloads.lisp b/downloads.lisp new file mode 100644 index 0000000..226095e --- /dev/null +++ b/downloads.lisp @@ -0,0 +1,171 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: downloads.cl +;;;; Purpose: Generate downloads page +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Aug 2002 +;;;; +;;;; $Id: downloads.lisp,v 1.1 2002/09/30 10:26:43 kevin Exp $ +;;;; +;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; LML 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) +;;;; ************************************************************************* + +(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) +(in-package :lml) + + +(defvar *ftp-base*) +(defvar *ftp-url*) +(defvar *base-name*) +(defvar *section-indent* 0) +(defvar *signed* nil) + +(defun list-files (files) + "List files in a directory for downloading" + ;;files.sort() + (mapcar #'print-file files)) + +(defun strip-ftp-base (file) + (let ((fdir (pathname-directory file)) + (bdir (pathname-directory *ftp-base*))) + (make-pathname + :name (pathname-name file) + :type (pathname-type file) + :directory + (when (> (length bdir) (length fdir)) + (append '(:absolute) + (subseq (length bdir) (length fdir) fdir)))))) + +(defun print-file (file) + (let ((size 0) + (modtime (date-string (file-write-date file))) + (basename (namestring + (make-pathname :name (pathname-name file) + :type (pathname-type file)))) + (ftp-name (strip-ftp-base file)) + (sig-path (concatenate 'string (namestring file) ".asc"))) + (when (plusp (length basename)) + (with-open-file (strm file :direction :input) + (setq size (round (/ (file-length strm) 1024)))) + (lml-print "~A" *ftp-url* ftp-name basename) + (lml-print "") + (lml-print " (~A, ~:D KB)" modtime size) + (when (probe-file sig-path) + (setq *signed* t) + (lml-print " [Signature]" *ftp-url* ftp-name)) + (br)))) + +(defun display-header (name url) + (lml-print "