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