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