Skip to content
Snippets Groups Projects
Commit 7191adc2 authored by Gary King's avatar Gary King Committed by Robert P. Goldman
Browse files

* 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)
parent 786527bf
No related branches found
No related tags found
No related merge requests found
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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))))
......@@ -7,5 +7,6 @@
:components
((:file "file1")
(:file "level2/file2")
(:static-file "level2/static.file")
(:static-file "test-tmp.cl")))))
;;; -*- 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")
|#
)
......@@ -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>
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment