From 7191adc286910140f66845c940d1654a803fba7e Mon Sep 17 00:00:00 2001
From: Gary King <gwking@franz.com>
Date: Wed, 14 Oct 2009 09:27:46 -0400
Subject: [PATCH] * add `asdf-extensions` package and start to flesh it out

* apply patch to better handle relative source-file types (from Fare Rideau)

* improve logic of tag updating in bump-revision-and-tag.sh

* make test output nicer (from Fare Rideau)

* improve test-module-pathnames (from Fare Rideau)
---
 GNUmakefile                       |  1 +
 asdf.lisp                         | 75 ++++++++++++++++++++-----------
 bin/bump-revision-and-tag.sh      | 18 +++++++-
 test/script-support.lisp          |  4 +-
 test/test-module-pathnames.asd    |  1 +
 test/test-module-pathnames.script | 34 ++++++++++++--
 website/website.tmproj            | 25 ++++++++---
 7 files changed, 121 insertions(+), 37 deletions(-)

diff --git a/GNUmakefile b/GNUmakefile
index e34931a7..32eae646 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -30,6 +30,7 @@ archive-copy: archive
 	bin/rsync-cp.sh tmp/asdf*.tar.gz $(webhome_private)/archives
 	bin/link-tarball.sh $(clnet_home) $(user)
 	bin/rsync-cp.sh tmp/asdf.lisp $(webhome_private)
+	git push cl.net
 	git push --tags cl.net
 
 website-copy: FORCE
diff --git a/asdf.lisp b/asdf.lisp
index c1104e59..71ef1ed6 100644
--- a/asdf.lisp
+++ b/asdf.lisp
@@ -135,8 +135,21 @@
 	   #:output-files-for-system-and-operation
 	   #:*enable-asdf-binary-locations*
 	   #:implementation-specific-directory-name)
+  (:intern #:coerce-name
+	   #:system-registered-p
+	   #:asdf-message
+	   #:resolve-symlinks
+	   #:pathname-sans-name+type)
   (:use :cl))
 
+(defpackage #:asdf-extensions
+  (:use #:common-lisp #:asdf)
+  (:import-from #:asdf
+		#:coerce-name
+		#:system-registered-p
+		#:asdf-message
+		#:resolve-symlinks
+		#:pathname-sans-name+type))
 
 #+nil
 (error "The author of this file habitually uses #+nil to comment out ~
@@ -741,6 +754,7 @@ to `~a` which is not a directory.~@:>"
 (defmethod source-file-type ((c html-file) (s module)) "html")
 (defmethod source-file-type ((c static-file) (s module)) nil)
 
+#+(or)
 (defmethod component-relative-pathname ((component source-file))
   (multiple-value-bind (relative path name)
       (split-path-string (component-name component))
@@ -755,6 +769,18 @@ to `~a` which is not a directory.~@:>"
            name))
         (make-pathname :directory `(,relative ,@path) :name name :type type)))))
 
+
+(defmethod component-relative-pathname ((component source-file))
+  (multiple-value-bind (relative path name)
+      (split-path-string (component-name component))
+    (let ((type (source-file-type component (component-system component)))
+          (relative-pathname (slot-value component 'relative-pathname)))
+      (merge-pathnames
+       (or relative-pathname (make-pathname :directory `(,relative ,@path)))
+       (if type
+           (make-pathname :name name :type type)
+           name)))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; operations
 
@@ -1872,6 +1898,30 @@ applied by the plain `*source-to-target-mappings*`."
 	  (setf result (logior result (ash (read-byte s) (* 8 i)))))
     result))
 
+(defun parse-file-location-info (s)
+  (let ((start (file-position s))
+	(total-length (read-little-endian s))
+	(end-of-header (read-little-endian s))
+	(fli-flags (read-little-endian s))
+	(local-volume-offset (read-little-endian s))
+	(local-offset (read-little-endian s))
+	(network-volume-offset (read-little-endian s))
+	(remaining-offset (read-little-endian s)))
+    (declare (ignore total-length end-of-header local-volume-offset))
+    (unless (zerop fli-flags)
+      (cond
+	((logbitp 0 fli-flags)
+	  (file-position s (+ start local-offset)))
+	((logbitp 1 fli-flags)
+	  (file-position s (+ start
+			      network-volume-offset
+			      #x14))))
+      (concatenate 'string
+	(read-null-terminated-string s)
+	(progn
+	  (file-position s (+ start remaining-offset))
+	  (read-null-terminated-string s))))))
+
 (defun parse-windows-shortcut (pathname)
   (with-open-file (s pathname :element-type '(unsigned-byte 8))
     (handler-case
@@ -1902,31 +1952,6 @@ applied by the plain `*source-to-target-mappings*`."
       (end-of-file ()
 	nil))))
 
-(defun parse-file-location-info (s)
-  (let ((start (file-position s))
-	(total-length (read-little-endian s))
-	(end-of-header (read-little-endian s))
-	(fli-flags (read-little-endian s))
-	(local-volume-offset (read-little-endian s))
-	(local-offset (read-little-endian s))
-	(network-volume-offset (read-little-endian s))
-	(remaining-offset (read-little-endian s)))
-    (declare (ignore total-length end-of-header local-volume-offset))
-    (unless (zerop fli-flags)
-      (cond
-	((logbitp 0 fli-flags)
-	  (file-position s (+ start local-offset)))
-	((logbitp 1 fli-flags)
-	  (file-position s (+ start
-			      network-volume-offset
-			      #x14))))
-      (concatenate 'string
-	(read-null-terminated-string s)
-	(progn
-	  (file-position s (+ start remaining-offset))
-	  (read-null-terminated-string s))))))
-
-
 (pushnew :asdf *features*)
 
 #+sbcl
diff --git a/bin/bump-revision-and-tag.sh b/bin/bump-revision-and-tag.sh
index 91be9b42..d8e15fbf 100755
--- a/bin/bump-revision-and-tag.sh
+++ b/bin/bump-revision-and-tag.sh
@@ -17,7 +17,7 @@ fi
 
 major=`expr //$tag : '//\(.*\)\.'`
 minor=`expr //$tag : '.*\.\(.*\)'`
-
+minor=`echo "$minor" | gawk -F - '{print $1}'`
 if [ "$major" == "" ]; then
   echo "error: unable to parse major version in $tag"
   exit -1
@@ -28,13 +28,29 @@ if [ "$minor" == "" ]; then
 fi
 
 bumped=`expr $minor + 1`
+if [ ! "$?" == "0" ]; then
+    echo "Unable to compute new version from $minor"
+    exit -2
+fi
 new_version="$major.$bumped"
 
 cp asdf.lisp asdf.bak
 perl -pi -e "s/REVISION:[^\"]*\"/REVISION:$new_version\"/" asdf.lisp
+if [ ! "$?" == "0" ]; then
+    echo "Unable to perl replace version"
+    exit -3
+fi
 
 echo "Update reversion and commit"
 git add asdf.lisp
+if [ ! "$?" == "0" ]; then
+    echo "Unable to git add"
+    exit -4
+fi
 git commit -m "update ASDF version to $new_version"
+if [ ! "$?" == "0" ]; then
+    echo "Unable to git commit"
+    exit -5
+fi
 
 bin/tag-release.sh $new_version
diff --git a/test/script-support.lisp b/test/script-support.lisp
index 46540fd4..5f5407f4 100644
--- a/test/script-support.lisp
+++ b/test/script-support.lisp
@@ -30,7 +30,7 @@
 (defmacro quit-on-error (&body body)
   `(handler-case 
       (progn ,@body
-	     (leave-lisp "Script succeeded" 0))
+	     (leave-lisp "~&Script succeeded~%" 0))
     (error (c)
       (format *error-output* "~a" c)
-      (leave-lisp "Script failed" 1))))
+      (leave-lisp "~&Script failed~%" 1))))
diff --git a/test/test-module-pathnames.asd b/test/test-module-pathnames.asd
index b7d3184f..f2581182 100644
--- a/test/test-module-pathnames.asd
+++ b/test/test-module-pathnames.asd
@@ -7,5 +7,6 @@
 	    :components
 	    ((:file "file1")
 	     (:file "level2/file2")
+	     (:static-file "level2/static.file")
 	     (:static-file "test-tmp.cl")))))
 
diff --git a/test/test-module-pathnames.script b/test/test-module-pathnames.script
index 68549e36..10383b25 100644
--- a/test/test-module-pathnames.script
+++ b/test/test-module-pathnames.script
@@ -1,31 +1,57 @@
 ;;; -*- Lisp -*-
 (load "script-support")
 (load "../asdf")
-(quit-on-error 
- (setf asdf:*central-registry* '(*default-pathname-defaults*))
- (asdf:operate 'asdf:load-op 'test-module-pathnames))
 
 (quit-on-error 
+ (setf asdf:*central-registry* '(*default-pathname-defaults*))
+ (asdf:load-system 'test-module-pathnames)
+ (flet ((submodule (module name)
+          (find name (asdf:module-components module)
+                :key #'asdf:component-name :test #'equal))
+        (pathname-foo (x)
+          (list (pathname-directory x) (pathname-name x) (pathname-type x))))
+   (let* ((system (asdf:find-system "test-module-pathnames"))
+          (level1 (submodule system "sources/level1"))
+          (static (submodule level1 "level2/static.file"))
+          (test-tmp (submodule level1 "test-tmp.cl")))
+     (assert (equal (pathname-foo (asdf:component-relative-pathname test-tmp))
+                    '((:relative) "test-tmp" "cl"))
+             nil
+             "Didn't get the name of test-tmp.cl right")
+     (assert (equal
+              (pathname-foo (asdf:component-relative-pathname static))
+              '((:relative "level2") "static" "file"))
+             nil
+             "Didn't get the name of static.file right"))) 
  (assert (find-package :test-package) nil
 	 "package test-package not found")
  (assert (find-symbol (symbol-name '*file-tmp*) :test-package) nil
 	 "symbol `*file-tmp*` not found")
  (assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
 	 nil "symbol `*file-tmp*` has wrong value")
+
+#| ; must be adapted to ABL
  (assert (probe-file (merge-pathnames 
 		      (make-pathname 
 		       :name "file1"
 		       :type (pathname-type (compile-file-pathname "x"))
 		       :directory '(:relative "sources" "level1"))))
 	 nil "compiled file not found")
+|#
 
  (assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil
 	 "symbol `*file-tmp2*` not found")
  (assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
 	 nil "symbol `*file-tmp2*` has wrong value")
+
+#| ; must be adapted to ABL
+
  (assert (probe-file (merge-pathnames 
 		      (make-pathname 
 		       :name "file2"
 		       :type (pathname-type (compile-file-pathname "x"))
 		       :directory '(:relative "sources" "level1" "level2"))))
-	 nil "compiled file not found"))
+	 nil "compiled file not found")
+|#
+
+)
diff --git a/website/website.tmproj b/website/website.tmproj
index 9283f7e8..9ecfec7f 100644
--- a/website/website.tmproj
+++ b/website/website.tmproj
@@ -3,14 +3,16 @@
 <plist version="1.0">
 <dict>
 	<key>currentDocument</key>
-	<string>source/glossary.md</string>
+	<string>source/getting-started.mmd</string>
 	<key>documents</key>
 	<array>
 		<dict>
 			<key>filename</key>
 			<string>source/getting-started.mmd</string>
 			<key>lastUsed</key>
-			<date>2009-09-14T14:43:49Z</date>
+			<date>2009-09-27T12:25:04Z</date>
+			<key>selected</key>
+			<true/>
 		</dict>
 		<dict>
 			<key>filename</key>
@@ -40,9 +42,7 @@
 			<key>filename</key>
 			<string>source/glossary.md</string>
 			<key>lastUsed</key>
-			<date>2009-09-14T14:43:49Z</date>
-			<key>selected</key>
-			<true/>
+			<date>2009-09-27T12:25:04Z</date>
 		</dict>
 		<dict>
 			<key>filename</key>
@@ -125,6 +125,20 @@
 			<key>firstVisibleLine</key>
 			<integer>0</integer>
 		</dict>
+		<key>source/getting-started.mmd</key>
+		<dict>
+			<key>caret</key>
+			<dict>
+				<key>column</key>
+				<integer>0</integer>
+				<key>line</key>
+				<integer>0</integer>
+			</dict>
+			<key>firstVisibleColumn</key>
+			<integer>0</integer>
+			<key>firstVisibleLine</key>
+			<integer>106</integer>
+		</dict>
 		<key>source/git.mmd</key>
 		<dict>
 			<key>caret</key>
@@ -317,6 +331,7 @@
 		<string>source/copyright.md</string>
 		<string>source/resources/header.md</string>
 		<string>source/glossary.md</string>
+		<string>source/getting-started.mmd</string>
 		<string>source/manual.mmd</string>
 		<string>source/git.mmd</string>
 		<string>source/user-guide.mmd</string>
-- 
GitLab