X-Git-Url: http://git.kpe.io/?p=lml.git;a=blobdiff_plain;f=downloads.lisp;h=2c1d2b2eaaf3872e14d28f1872fff83a049ff4bb;hp=36f599c2e612e361d1f411dadb193fa4f10c5e4f;hb=c18c02e07944ea56688b4fc350dbdab400f84fe1;hpb=5151ac10e8472126199e05ff8e5ab382ecba3c68 diff --git a/downloads.lisp b/downloads.lisp index 36f599c..2c1d2b2 100644 --- a/downloads.lisp +++ b/downloads.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: downloads.lisp,v 1.9 2003/06/06 21:59:30 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://www.gnu.org/licenses/gpl.html) ;;;; ************************************************************************* -(in-package lml) +(in-package #:lml) (defvar *dl-base*) @@ -32,32 +32,32 @@ (defun strip-dl-base (file) (let ((fdir (pathname-directory file)) - (bdir (pathname-directory *dl-base*))) + (bdir (pathname-directory *dl-base*))) (make-pathname :name (pathname-name file) :type (pathname-type file) - :directory + :directory (when (> (length fdir) (length bdir)) - (append '(:absolute) - (subseq fdir (length bdir) (length fdir))))))) - + (append '(:absolute) + (subseq fdir (length bdir) (length 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)))) - (dl-name (strip-dl-base file)) - (sig-path (concatenate 'string (namestring file) ".asc"))) + (modtime (date-string (file-write-date file))) + (basename (namestring + (make-pathname :name (pathname-name file) + :type (pathname-type 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)))) + (setq size (round (/ (file-length strm) 1024)))) (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]" *dl-url* dl-name)) + (setq *signed* t) + (lml-format " [Signature]" *dl-url* dl-name)) (br)))) (defun display-header (name url) @@ -69,9 +69,9 @@ (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) (lml-format "~A" *section-indent* title *section-indent*)) @@ -80,14 +80,24 @@ (when (>= (length name) len-base-name) (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) (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 (sort-pathnames (filter-against-base (directory pat))))) + (let ((files (sort-pathnames (filter-latest + (filter-against-base (directory pat)))))) (when files (print-sect-title title) (lml-princ "
") @@ -97,62 +107,66 @@ (defun display-sections (sects) (when sects (let ((title (car sects)) - (value (cadr sects))) + (value (cadr sects))) (if (consp title) - (dolist (sect sects) (display-sections sect)) - (if (consp value) - (progn - (print-sect-title title) - (incf *section-indent*) - (display-sections value) - (decf *section-indent*)) - (display-one-section title value)))))) - -(defun display-page (pkg-name pkg-base dl-base dl-url sects) + (dolist (sect sects) (display-sections sect)) + (if (consp value) + (progn + (print-sect-title title) + (incf *section-indent*) + (display-sections value) + (decf *section-indent*)) + (display-one-section title value)))))) + +(defun display-page (pkg-name pkg-base dl-base dl-url giturl gitweb sects) (let ((*section-indent* 3) - (*dl-base* dl-base) - (*dl-url* dl-url) - (*base-name* pkg-base) - (*signed* nil)) + (*dl-base* dl-base) + (*dl-url* dl-url) + (*base-name* pkg-base) + (*signed* nil)) (display-header pkg-name dl-url) (map nil #'display-sections sects) + (when giturl + (lml-format "

Git Repository

~A" giturl) + (when gitweb + (lml-format "  [Browse]" gitweb))) (display-footer))) -(defun std-dl-page (pkg-name pkg-base dl-base dl-url) +(defun std-dl-page (pkg-name pkg-base dl-base dl-url &optional giturl gitweb) (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 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 dl-base dl-url) + (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 dl-base dl-url giturl gitweb + `(("Manual" ,doc-path) + ("Source Code" + (("Unix (.tar.gz)" ,tgz-path) + ("Windows (.zip)" ,zip-path)))))))) + +(defun full-dl-page (pkg-name pkg-base dl-base dl-url &optional giturl gitweb) (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)) - (deb-path (merge-pathnames - (make-pathname :directory '(:relative "linux-debian") - :type :wild :name :wild) - base)) - (rpm-path (merge-pathnames - (make-pathname :directory '(:relative "linux-rpm") - :type :wild :name :wild) - base)) - (w32-path (merge-pathnames - (make-pathname :directory '(:relative "win32") - :type :wild :name :wild) - base))) - (display-page pkg-name pkg-base dl-base dl-url - `(("Manual" ,doc-path) - ("Source Code" - (("Unix (.tar.gz)" ,tgz-path) - ("Windows (.zip)" ,zip-path))) - ("Binaries" - (("Linux Binaries" - (("Debian Linux" ,deb-path) - ("RedHat Linux" ,rpm-path))) - ("Windows Binaries" ,w32-path)))))))) + (zip-path (make-pathname :defaults base :type "zip" :name :wild)) + (doc-path (make-pathname :defaults base :type "pdf" :name :wild)) + (deb-path (merge-pathnames + (make-pathname :directory '(:relative "linux-debian") + :type :wild :name :wild) + base)) + (rpm-path (merge-pathnames + (make-pathname :directory '(:relative "linux-rpm") + :type :wild :name :wild) + base)) + (w32-path (merge-pathnames + (make-pathname :directory '(:relative "win32") + :type :wild :name :wild) + base))) + (display-page pkg-name pkg-base dl-base dl-url giturl gitweb + `(("Manual" ,doc-path) + ("Source Code" + (("Unix (.tar.gz)" ,tgz-path) + ("Windows (.zip)" ,zip-path))) + ("Binaries" + (("Linux Binaries" + (("Debian Linux" ,deb-path) + ("RedHat Linux" ,rpm-path))) + ("Windows Binaries" ,w32-path))))))))