X-Git-Url: http://git.kpe.io/?p=lml2.git;a=blobdiff_plain;f=downloads.lisp;h=6509feea2391f630b54d2d69d032d1d7d969badc;hp=f6a0bf4aafb6a4b1ce5f4d984890a4a627080581;hb=f6fab048b73e0b2d1deb2c3c93703fdacf4b5e22;hpb=d4e3a818df067aff2883cfc205e3370d707b75e5 diff --git a/downloads.lisp b/downloads.lisp index f6a0bf4..6509fee 100644 --- a/downloads.lisp +++ b/downloads.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: downloads.lisp,v 1.6 2003/07/12 18:13:42 kevin Exp $ +;;;; $Id$ ;;;; ;;;; This file, part of LML2, is Copyright (c) 2000-2003 by Kevin Rosenberg. ;;;; Rights of modification and redistribution are in the LICENSE file. @@ -26,51 +26,52 @@ (defun strip-dl-base (file base) (let ((fdir (pathname-directory file)) - (bdir (pathname-directory base))) + (bdir (pathname-directory 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 dl-data) (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 (dl-data-base dl-data))) - (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 (dl-data-base dl-data))) + (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-data-url dl-data) dl-name basename) + (dl-data-url dl-data) dl-name basename) (lml-princ "") (lml-format " (~A, ~:D KB)" modtime size) (when (probe-file sig-path) - (setf (dl-data-signed dl-data) t) - (lml-format " [Signature]" - (dl-data-url dl-data) dl-name)) + (setf (dl-data-signed dl-data) t) + (lml-format " [Signature]" + (dl-data-url dl-data) dl-name)) (html :br)))) (defun display-header (name url) (lml-princ "

Download

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

Browse ~A Download Site

" name) - (lml-format "~A" url url)) + (let ((*print-circle* nil)) + (lml-format "~A" url url))) (defun display-footer (dl-data) (when (dl-data-signed dl-data) (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 dl-data) (lml-format "~A" - (dl-data-indent dl-data) title (dl-data-indent dl-data))) + (dl-data-indent dl-data) title (dl-data-indent dl-data))) (defun match-base-name? (name base-name) (let ((len-base-name (length base-name))) @@ -79,7 +80,7 @@ (defun match-base-name-latest? (name base-name) (let* ((latest (concatenate 'string base-name "-latest")) - (len-latest (length latest))) + (len-latest (length latest))) (when (>= (length name) len-latest) (string= name latest :end1 len-latest :end2 len-latest)))) @@ -98,9 +99,9 @@ (defun display-one-section (title pat dl-data) (let ((files (sort-pathnames - (filter-latest - (filter-against-base (directory pat) (dl-data-name dl-data)) - (dl-data-name dl-data))))) + (filter-latest + (filter-against-base (directory pat) (dl-data-name dl-data)) + (dl-data-name dl-data))))) (when files (print-sect-title title dl-data) (lml-princ "
") @@ -110,64 +111,78 @@ (defun display-sections (sects dl-data) (when sects (let ((title (car sects)) - (value (cadr sects))) + (value (cadr sects))) (if (consp title) - (dolist (sect sects) - (display-sections sect dl-data)) - (if (consp value) - (progn - (print-sect-title title dl-data) - (incf (dl-data-indent dl-data)) - (display-sections value dl-data) - (decf (dl-data-indent dl-data))) - (display-one-section title value dl-data)))))) - -(defun display-page (pkg-name pkg-base dl-base dl-url sects) + (dolist (sect sects) + (display-sections sect dl-data)) + (if (consp value) + (progn + (print-sect-title title dl-data) + (incf (dl-data-indent dl-data)) + (display-sections value dl-data) + (decf (dl-data-indent dl-data))) + (display-one-section title value dl-data)))))) + +(defun display-page (pkg-name pkg-base dl-base dl-url giturl gitweb sects) (let ((dl-data (make-dl-data :indent 3 - :base dl-base - :url dl-url - :name pkg-base - :signed nil))) + :base dl-base + :url dl-url + :name pkg-base + :signed nil))) (display-header pkg-name dl-url) (dolist (sect sects) (display-sections sect dl-data)) + (when giturl + (lml-format "

Git Repository

~A" giturl) + (when gitweb + (lml-format "  [Browse]" gitweb))) (display-footer dl-data))) -(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)) + (mac-path (merge-pathnames + (make-pathname :directory '(:relative "mac") + :type :wild :name :wild) + base)) + (linux-path (merge-pathnames + (make-pathname :directory '(:relative "linux") + :type :wild :name :wild) + base))) + (display-page pkg-name pkg-base dl-base dl-url giturl gitweb + `(("Manual" ,doc-path) + ,@(when (or (directory tgz-path) (directory zip-path)) + `(("Source Code" + (("Unix (.tar.gz)" ,tgz-path) + ("Windows (.zip)" ,zip-path))))) + ("Binaries" + (("Linux Binaries" ,linux-path) + ("Linux .deb Packages" ,deb-path) + ("Linux .rpm Packages" ,rpm-path) + ("Mac Binaries" ,mac-path) + ("Windows Binaries" ,w32-path))))))))