X-Git-Url: http://git.kpe.io/?p=lml.git;a=blobdiff_plain;f=downloads.lisp;h=d78f776ffcee171a3d52b6804c186a1ba5671f34;hp=4223820269707f28ab96e37c3de86cdf41c9094c;hb=2dcfda178f817bec62b9f51248d96799d254d686;hpb=a172835de847276a772b8f980fb2866d0a715e30 diff --git a/downloads.lisp b/downloads.lisp index 4223820..d78f776 100644 --- a/downloads.lisp +++ b/downloads.lisp @@ -2,12 +2,12 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: downloads.cl +;;;; Name: downloads.lisp ;;;; Purpose: Generate downloads page ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: downloads.lisp,v 1.7 2003/01/24 08:51:41 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,12 +16,11 @@ ;;;; (http://www.gnu.org/licenses/gpl.html) ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :lml) +(in-package #:lml) -(defvar *ftp-base*) -(defvar *ftp-url*) +(defvar *dl-base*) +(defvar *dl-url*) (defvar *base-name*) (defvar *section-indent* 0) (defvar *signed* nil) @@ -31,9 +30,9 @@ ;;files.sort() (mapcar #'print-file files)) -(defun strip-ftp-base (file) +(defun strip-dl-base (file) (let ((fdir (pathname-directory file)) - (bdir (pathname-directory *ftp-base*))) + (bdir (pathname-directory *dl-base*))) (make-pathname :name (pathname-name file) :type (pathname-type file) @@ -48,29 +47,29 @@ (basename (namestring (make-pathname :name (pathname-name file) :type (pathname-type file)))) - (ftp-name (strip-ftp-base file)) + (dl-name (strip-dl-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-format "~A" *ftp-url* ftp-name basename) + (lml-format "~A" *dl-url* dl-name basename) (lml-princ "") (lml-format " (~A, ~:D KB)" modtime size) (when (probe-file sig-path) (setq *signed* t) - (lml-format " [Signature]" *ftp-url* ftp-name)) + (lml-format " [Signature]" *dl-url* dl-name)) (br)))) (defun display-header (name url) (lml-princ "

Download

") (lml-princ "
") - (lml-format "

Browse ~A FTP Site

" name) + (lml-format "

Browse ~A Download Site

" name) (lml-format "~A" url url)) (defun display-footer () (when *signed* (lml-princ "

GPG Public Key

") - (lml-princ "Use this key to verify file signtatures")) + (lml-princ "Use this key to verify file signtatures")) (lml-princ "
")) (defun print-sect-title (title) @@ -79,40 +78,38 @@ (defun match-base-name? (name) (let ((len-base-name (length *base-name*))) (when (>= (length name) len-base-name) - (dotimes (i len-base-name) - (declare (fixnum i)) - (unless (char= (char *base-name* i) - (char name i)) - (return-from match-base-name? nil))))) - t) + (string= name *base-name* :end1 len-base-name :end2 len-base-name)))) + +(defun match-base-name-latest? (name) + (let* ((latest (concatenate 'string *base-name* "-latest")) + (len-latest (length latest))) + (when (>= (length name) len-latest) + (string= name latest :end1 len-latest :end2 len-latest)))) (defun filter-against-base (files) - (let ((filtered '())) - (dolist (f files) - (let ((name (pathname-name f))) - (when (match-base-name? name) - (push f filtered)))) - (when filtered - (sort filtered #'(lambda (a b) (when (and a b) - (string< - (namestring a) - (namestring b)))))))) + (delete-if-not #'(lambda (f) (match-base-name? (pathname-name f))) files)) + +(defun filter-latest (files) + (delete-if #'(lambda (f) (match-base-name-latest? (pathname-name f))) files)) + +(defun sort-pathnames (list) + (sort list #'(lambda (a b) (string< (namestring a) (namestring b))))) (defun display-one-section (title pat) - (let ((files (filter-against-base (directory pat)))) + (let ((files (sort-pathnames (filter-latest + (filter-against-base (directory pat)))))) (when files (print-sect-title title) (lml-princ "
") (list-files files) (lml-princ "
")))) - (defun display-sections (sects) (when sects (let ((title (car sects)) (value (cadr sects))) (if (consp title) - (map nil #'display-sections sects) + (dolist (sect sects) (display-sections sect)) (if (consp value) (progn (print-sect-title title) @@ -121,29 +118,29 @@ (decf *section-indent*)) (display-one-section title value)))))) -(defun display-page (pkg-name pkg-base ftp-base ftp-url sects) +(defun display-page (pkg-name pkg-base dl-base dl-url sects) (let ((*section-indent* 3) - (*ftp-base* ftp-base) - (*ftp-url* ftp-url) + (*dl-base* dl-base) + (*dl-url* dl-url) (*base-name* pkg-base) (*signed* nil)) - (display-header pkg-name ftp-url) + (display-header pkg-name dl-url) (map nil #'display-sections sects) (display-footer))) -(defun std-dl-page (pkg-name pkg-base ftp-base ftp-url) - (let ((base (parse-namestring ftp-base))) +(defun std-dl-page (pkg-name pkg-base dl-base dl-url) + (let ((base (parse-namestring dl-base))) (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild)) (zip-path (make-pathname :defaults base :type "zip" :name :wild)) (doc-path (make-pathname :defaults base :type "pdf" :name :wild))) - (display-page pkg-name pkg-base ftp-base ftp-url + (display-page pkg-name pkg-base dl-base dl-url `(("Manual" ,doc-path) ("Source Code" (("Unix (.tar.gz)" ,tgz-path) ("Windows (.zip)" ,zip-path)))))))) -(defun full-dl-page (pkg-name pkg-base ftp-base ftp-url) - (let ((base (parse-namestring ftp-base))) +(defun full-dl-page (pkg-name pkg-base dl-base dl-url) + (let ((base (parse-namestring dl-base))) (let ((tgz-path (make-pathname :defaults base :type "gz" :name :wild)) (zip-path (make-pathname :defaults base :type "zip" :name :wild)) (doc-path (make-pathname :defaults base :type "pdf" :name :wild)) @@ -159,7 +156,7 @@ (make-pathname :directory '(:relative "win32") :type :wild :name :wild) base))) - (display-page pkg-name pkg-base ftp-base ftp-url + (display-page pkg-name pkg-base dl-base dl-url `(("Manual" ,doc-path) ("Source Code" (("Unix (.tar.gz)" ,tgz-path)