From 0591d702c44b8962c8a2eada5ce7f77966d63ce9 Mon Sep 17 00:00:00 2001 From: Gary King <gwking@franz.com> Date: Wed, 15 Jul 2009 10:17:39 -0400 Subject: [PATCH] (for real this time) modest make improvements * extract LICENSE file out of asdf.lisp directly (DRY wins) * make `make-temporary-package` more mixed-case friendly --- .gitignore | 2 + GNUmakefile | 6 +- asdf.lisp | 9 ++- bin/make-helper.lisp | 160 ++++++++++++++++++++++++++----------------- 4 files changed, 112 insertions(+), 65 deletions(-) diff --git a/.gitignore b/.gitignore index c1f922a5..545c4e6c 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,8 @@ common-lisp.net init-lisp.lisp website/changelog.xml +# We build these at various stages in the make process +LICENSE website/output/ test-results/ lift-local.config diff --git a/GNUmakefile b/GNUmakefile index d267c783..c8c56954 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -18,6 +18,8 @@ endif install: archive-copy archive: FORCE + sbcl --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \ + --eval "(rewrite-license)" --eval "(quit)" bin/build-tarball.sh archive-copy: archive @@ -53,5 +55,7 @@ test-all: FORCE @for lisp in $(lisps); do \ make test lisp=$$lisp; \ done - sbcl --userinit /dev/null --sysinit /dev/null --load test/make-webpage.lisp --eval "(quit)" + sbcl --userinit /dev/null --sysinit /dev/null --load bin/make-helper.lisp \ + --eval "(write-test-pages)" --eval "(quit)" + FORCE: \ No newline at end of file diff --git a/asdf.lisp b/asdf.lisp index 6a8453ba..07589eb9 100644 --- a/asdf.lisp +++ b/asdf.lisp @@ -18,6 +18,11 @@ ;;; is the latest development version, whereas the revision tagged ;;; RELEASE may be slightly older but is considered `stable' +;;; -- LICENSE START +;;; (This is the MIT / X Consortium license as taken from +;;; http://www.opensource.org/licenses/mit-license.html on or about +;;; Monday; July 13, 2009) +;;; ;;; Copyright (c) 2001-2009 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -38,6 +43,8 @@ ;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION ;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION ;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +;;; +;;; -- LICENSE END ;;; the problem with writing a defsystem replacement is bootstrapping: ;;; we can't use defsystem to compile it. Hence, all in one file @@ -498,7 +505,7 @@ to `~a` which is not a directory.~@:>" (defun make-temporary-package () (flet ((try (counter) (ignore-errors - (make-package (format nil "ASDF~D" counter) + (make-package (format nil "~a~D" 'asdf counter) :use '(:cl :asdf))))) (do* ((counter 0 (+ counter 1)) (package (try counter) (try counter))) diff --git a/bin/make-helper.lisp b/bin/make-helper.lisp index 667c7287..acbf93eb 100644 --- a/bin/make-helper.lisp +++ b/bin/make-helper.lisp @@ -1,61 +1,8 @@ (in-package #:common-lisp-user) - #+(or) (build-web-page "/repository/git/asdf/test/results/" "/tmp/x.html" :if-exists :supersede) -(defun extract-summary (pathname stream) - (with-open-file (in pathname :direction :input - :if-does-not-exist :error) - (let ((start nil)) - (loop for line = (read-line in nil :eof) - until (eq line :eof) do - (when (and (> (length line) 5) (string-equal "-#---" (subseq line 0 5))) - (setf start t)) - (when start - (format stream "~&~a~%" line)))))) - -(defun html-header (stream title style-sheet) - (format stream "~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" - \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">") - (format stream "~&<html>~&<head>") - (when title - (format stream "~&<title>~a</title>" title)) - (when style-sheet - (unless (search ".css" style-sheet) - (setf style-sheet (concatenate 'string style-sheet ".css"))) - (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />" - style-sheet)) - (format stream "~&</head>~&<body>")) - -(defun html-footer (stream) - (format stream "<div id=\"footer\">") - (format stream "~&generated on ~a" - (format-date "%B %d, %Y" (get-universal-time))) - (format stream "</div>") - (format stream "~&</body></html>")) - - -(defun build-web-page (input-directory output-file &key (if-exists :error) - (title "ASDF test report") (style-sheet "styles.css")) - (with-open-file (stream output-file - :direction :output - :if-exists if-exists - :if-does-not-exist :create) - (html-header stream title style-sheet) - (format stream "~&~%<h1>ASDF Test results</h1>~%") - - (dolist (pathname (directory - (merge-pathnames (make-pathname :name :wild :type "text") - input-directory))) - (print pathname) - (format stream "~&~%<h2>~a</h2>~%" (pathname-name pathname)) - (format stream "~&<pre>~%") - (extract-summary pathname stream) - (format stream "~&</pre>~%")) - (html-footer stream) - )) - ;;; metatilities-base ;;; because sometimes copy and paste is just too easy @@ -235,13 +182,100 @@ None of %c, %F, %p, %x, %X, %Z, %z are implemented." ;;; metatilites-base -(let* ((*default-pathname-defaults* (make-pathname :name nil :type nil :defaults *load-truename*)) - (source (merge-pathnames - (make-pathname - :directory '(:relative "results")))) - (output (merge-pathnames (make-pathname - :directory '(:relative :back "website" "output") - :name "test-results" - :type "html")))) - (print (list source output)) - (build-web-page source output :if-exists :supersede)) + +(defun extract-summary (pathname stream) + (with-open-file (in pathname :direction :input + :if-does-not-exist :error) + (let ((start nil)) + (loop for line = (read-line in nil :eof) + until (eq line :eof) do + (when (and (> (length line) 5) (string-equal "-#---" (subseq line 0 5))) + (setf start t)) + (when start + (format stream "~&~a~%" line)))))) + +(defun html-header (stream title style-sheet) + (format stream "~&<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" + \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">") + (format stream "~&<html>~&<head>") + (when title + (format stream "~&<title>~a</title>" title)) + (when style-sheet + (unless (search ".css" style-sheet) + (setf style-sheet (concatenate 'string style-sheet ".css"))) + (format stream "~&<link type='text/css' href='~a' rel='stylesheet' />" + style-sheet)) + (format stream "~&</head>~&<body>")) + +(defun html-footer (stream) + (format stream "<div id=\"footer\">") + (format stream "~&generated on ~a" + (format-date "%B %d, %Y" (get-universal-time))) + (format stream "</div>") + (format stream "~&</body></html>")) + + +(defun build-web-page (input-directory output-file &key (if-exists :error) + (title "ASDF test report") (style-sheet "styles.css")) + (with-open-file (stream output-file + :direction :output + :if-exists if-exists + :if-does-not-exist :create) + (html-header stream title style-sheet) + (format stream "~&~%<h1>ASDF Test results</h1>~%") + + (dolist (pathname (directory + (merge-pathnames (make-pathname :name :wild :type "text") + input-directory))) + (print pathname) + (format stream "~&~%<h2>~a</h2>~%" (pathname-name pathname)) + (format stream "~&<pre>~%") + (extract-summary pathname stream) + (format stream "~&</pre>~%")) + (html-footer stream) + )) + +(defun extract-license (input-pathname output-pathname) + (with-open-file (in input-pathname :direction :input + :if-does-not-exist :error) + (with-open-file (out output-pathname + :direction :output + :if-does-not-exist :create + :if-exists :error) + (let* ((state nil) + (flag ";;; -- LICENSE") + (flag-length (length flag))) + (loop for line = (read-line in nil :eof) + until (eq line :eof) do + (when (and (> (length line) flag-length) + (string-equal flag (subseq line 0 flag-length))) + (if (eq state :running) + (return) + (setf state :starting))) + (when (eq state :running) + (format out "~&~a~%" (subseq line (min (length line) 4)))) + (when (eq state :starting) + (setf state :running))))))) + +(defun rewrite-license () + (let* ((*default-pathname-defaults* + (make-pathname :name nil :type nil :defaults *load-truename*)) + (output (merge-pathnames (make-pathname :name "LICENSE")))) + (when (probe-file output) + (delete-file output)) + (extract-license + (merge-pathnames (make-pathname :name "asdf" :type "lisp")) + output))) + +(defun write-web-pages () + (let* ((*default-pathname-defaults* (make-pathname :name nil :type nil :defaults *load-truename*)) + (source (merge-pathnames + (make-pathname + :directory '(:relative "results")))) + (output (merge-pathnames (make-pathname + :directory '(:relative :back "website" "output") + :name "test-results" + :type "html")))) + (print (list source output)) + (build-web-page source output :if-exists :supersede))) + -- GitLab