Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
A
asdf
Project overview
Project overview
Details
Activity
Releases
Repository
Repository
Files
Commits
Branches
Tags
Contributors
Graph
Compare
Issues
0
Issues
0
List
Boards
Labels
Service Desk
Milestones
Merge Requests
0
Merge Requests
0
CI / CD
CI / CD
Pipelines
Jobs
Schedules
Operations
Operations
Incidents
Environments
Analytics
Analytics
CI / CD
Repository
Value Stream
Wiki
Wiki
Snippets
Snippets
Members
Members
Collapse sidebar
Close sidebar
Activity
Graph
Create a new issue
Jobs
Commits
Issue Boards
Open sidebar
Jan Moringen
asdf
Commits
a0317bc1
Commit
a0317bc1
authored
Apr 09, 2015
by
Francois-Rene Rideau
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
Remember failures and show them at the end.
parent
69c76bfe
Changes
14
Hide whitespace changes
Inline
Side-by-side
Showing
14 changed files
with
339 additions
and
204 deletions
+339
-204
.gitignore
.gitignore
+1
-0
doc/Makefile
doc/Makefile
+6
-3
tools/asdf-tools.asd
tools/asdf-tools.asd
+6
-5
tools/build.lisp
tools/build.lisp
+14
-17
tools/failure.lisp
tools/failure.lisp
+140
-0
tools/git.lisp
tools/git.lisp
+13
-19
tools/install-asdf.lisp
tools/install-asdf.lisp
+1
-1
tools/main.lisp
tools/main.lisp
+13
-26
tools/release.lisp
tools/release.lisp
+49
-57
tools/test-all.lisp
tools/test-all.lisp
+41
-39
tools/test-basic.lisp
tools/test-basic.lisp
+4
-4
tools/test-environment.lisp
tools/test-environment.lisp
+24
-16
tools/test-scripts.lisp
tools/test-scripts.lisp
+16
-6
tools/test-upgrade.lisp
tools/test-upgrade.lisp
+11
-11
No files found.
.gitignore
View file @
a0317bc1
...
...
@@ -24,6 +24,7 @@ doc/asdf.vrs
doc/asdf.t2d/
doc/asdf.dvi
doc/version.texinfo
doc/*.log
*.tmp
LICENSE
...
...
doc/Makefile
View file @
a0317bc1
...
...
@@ -16,16 +16,19 @@ version.texinfo: ../version.lisp-expr
head
-n
1
$^
| perl
-ne
'm|\"(.*)\"|; print "\@set VERSION $$1\n"'
>
$@
manual-html
:
asdf.texinfo version.texinfo
makeinfo
--html
asdf.texinfo
makeinfo
--html
asdf.texinfo
\
2>&1
>
manual-html.log
||
{
echo
"failed. See log in manual-html.log"
;
exit
1
;
}
asdf.html
:
asdf.texinfo version.texinfo
makeinfo
--html
--no-split
--no-headers
-o
asdf.html asdf.texinfo
makeinfo
--html
--no-split
--no-headers
-o
asdf.html asdf.texinfo
\
2>&1
>
asdf.html.log
||
{
echo
"failed. See log in asdf.html.log"
;
exit
1
;
}
asdf.info
:
asdf.texinfo version.texinfo
makeinfo asdf.texinfo
asdf.pdf
:
asdf.texinfo version.texinfo
texi2pdf asdf.texinfo
texi2pdf asdf.texinfo
\
2>&1
>
asdf.pdf.log
||
{
echo
"failed. See log in asdf.pdf.log"
;
exit
1
;
}
website
:
all
rsync
-lt
--no-g
${webfiles}
${website}
...
...
tools/asdf-tools.asd
View file @
a0317bc1
...
...
@@ -8,16 +8,17 @@
(
:feature
:sbcl
"sb-introspect"
))
:components
((
:file
"package"
)
(
:file
"main"
:depends-on
(
"package"
))
(
:file
"failure"
:depends-on
(
"package"
))
(
:file
"main"
:depends-on
(
"failure"
))
(
:file
"pathnames"
:depends-on
(
"package"
))
(
:file
"git"
:depends-on
(
"package"
))
(
:file
"build"
:depends-on
(
"pathnames"
))
(
:file
"version"
:depends-on
(
"pathnames"
))
(
:file
"version"
:depends-on
(
"failure"
))
(
:file
"invoke-lisp"
:depends-on
(
"package"
))
(
:file
"test-environment"
:depends-on
(
"pathnames"
"invoke-lisp"
"main"
))
(
:file
"build"
:depends-on
(
"test-environment"
))
(
:file
"git"
:depends-on
(
"test-environment"
))
(
:file
"test-basic"
:depends-on
(
"test-environment"
))
(
:file
"test-scripts"
:depends-on
(
"test-environment"
))
(
:file
"test-upgrade"
:depends-on
(
"test-environment"
"git"
))
(
:file
"test-all"
:depends-on
(
"test-environment"
))
(
:file
"installation"
:depends-on
(
"test-environment"
))
(
:file
"release"
:depends-on
(
"version"
"test-environment"
))))
(
:file
"release"
:depends-on
(
"version"
"test-environment"
"git"
))))
tools/build.lisp
View file @
a0317bc1
(
in-package
:asdf-tools
)
(
def
un
build-asdf
()
(
def
testcmd
build-asdf
()
"make sure asdf.lisp is built"
(
load-system
:asdf
)
(
success
))
(
load-system
:asdf
))
;;; Documentation
(
def
un
doc
()
(
def
testcmd
doc
()
"build documentation in doc/ directory"
(
run
'
(
make
)
:directory
(
pn
"doc/"
)
)
(
success
))
(
with-failure-context
(
"in doc/ directory"
)
(
run*
'
(
make
)
:directory
(
pn
"doc/"
))
))
(
def
un
website
()
(
def
testcmd
website
()
"publish documentation onto the public website"
(
run
'
(
make
website
)
:directory
(
pn
"doc/"
)
)
(
success
))
(
with-failure-context
(
"in doc/ directory"
)
(
run*
'
(
make
website
)
:directory
(
pn
"doc/"
))
))
;;; Line counting
(
def
un
wc
()
(
def
testcmd
wc
()
"count lines of lisp code in asdf and uiop"
(
with-asdf-dir
()
(
flet
((
lisp-only
(
x
)
(
remove
"lisp"
x
:test-not
'equal
:key
'pathname-type
)))
(
let
((
driver-files
(
mapcar
#'
(
lambda
(
x
)
(
subpathname
"uiop/"
x
))
(
lisp-only
(
uiop-files
))))
(
defsystem-files
(
lisp-only
(
asdf-defsystem-files
))))
(
run
`
(
pipe
(
wc
,@
driver-files
)
(
sort
-n
)))
(
run
*
`
(
pipe
(
wc
,@
driver-files
)
(
sort
-n
)))
(
terpri
)
(
run
`
(
pipe
(
wc
header.lisp
,@
defsystem-files
)
(
sort
-n
)))
(
run
*
`
(
pipe
(
wc
header.lisp
,@
defsystem-files
)
(
sort
-n
)))
(
terpri
)
(
run
`
(
pipe
(
wc
header.lisp
,@
driver-files
,@
defsystem-files
)
(
tail
-n
1
))))))
(
success
))
(
run*
`
(
pipe
(
wc
header.lisp
,@
driver-files
,@
defsystem-files
)
(
tail
-n
1
)))))))
;;; debug the source registry that is being used to execute these tools.
(
def
un
list-source-registry
()
(
def
testcmd
list-source-registry
()
"Display the source-registry cache"
(
writeln
(
sort
(
alexandria:hash-table-alist
asdf::*source-registry*
)
'string<
:key
'car
))
(
success
))
'string<
:key
'car
)))
tools/failure.lisp
0 → 100644
View file @
a0317bc1
;;;; Useful information when failing.
(
in-package
:asdf-tools
)
(
defvar
*fail-fast*
nil
)
(
defvar
*fail-verbose*
nil
)
(
defvar
*execution-context*
nil
)
;; context for debugging information
(
defvar
*failures*
nil
)
(
defvar
*failurep*
nil
)
;;;(defvar *failure-handler* nil)
(
define-condition
execution-error
(
error
)
())
(
defmethod
print-object
((
failure
execution-error
)
stream
)
(
if
*print-escape*
(
print-unreadable-object
(
failure
stream
:type
t
:identity
nil
)
(
let
((
*print-escape*
nil
))
(
print-object
failure
stream
)))
(
princ
"FAILED"
stream
)))
(
define-condition
execution-failure
(
execution-error
)
((
context
:initform
nil
:initarg
:context
:reader
failure-context
)
(
reason
:initarg
:reason
:reader
failure-reason
)))
(
defmethod
print-object
((
failure
execution-failure
)
stream
)
(
if
*print-escape*
(
call-next-method
)
(
format
stream
"~@[In ~{~A~^, ~}: ~]~:[FAILED~;~:*~A~]"
(
reverse
(
remove
nil
(
failure-context
failure
)))
(
failure-reason
failure
))))
(
define-condition
execution-failures
(
execution-error
)
((
failures
:initform
nil
:initarg
:failures
:reader
failure-list
)))
(
defmethod
print-object
((
failures
execution-failures
)
stream
)
(
if
*print-escape*
(
call-next-method
)
(
format
stream
"Failure~@[~P~:*~{~&~A~&~}~]"
(
reverse
(
failure-list
failures
)))))
(
defun
make-error
(
&optional
reason
&rest
arguments
)
(
etypecase
reason
(
error
reason
)
(
string
(
make-condition
'simple-error
:format-control
reason
:format-arguments
arguments
))
(
null
(
make-failures
))
(
symbol
(
apply
'make-condition
reason
arguments
))))
(
defun
fail!
(
&rest
reason-arguments
)
(
error
(
apply
'make-error
reason-arguments
)))
(
defun
success
(
&rest
values
)
"Return magic values that signal success"
(
cond
((
successp
values
)
(
apply
'values
values
))
((
failurep
values
)
(
apply
'values
values
))
(
t
(
apply
'values
t
'
#:success
values
))))
(
defun
failure
(
&optional
failures
)
"Return magic values that signal failure"
(
values
nil
'
#:failure
failures
))
(
defun
successp
(
value-list
)
(
and
(
length>=n-p
value-list
2
)
(
equal
(
subseq
value-list
0
2
)
(
multiple-value-list
(
success
)))))
(
defun
success-values
(
value-list
)
(
subseq
value-list
2
))
(
defun
failurep
(
value-list
)
(
and
(
length>=n-p
value-list
2
)
(
equal
(
subseq
value-list
0
2
)
(
subseq
(
multiple-value-list
(
failure
))
0
2
))))
(
defun
failure-failures
(
value-list
)
(
third
value-list
))
(
defun
success-if
(
test
&rest
failure-args
)
"If TEST, return success, otherwise, return failure with FAILURE-ARGS"
(
if
test
(
success
)
(
apply
'fail!
(
or
failure-args
'
(
"failed"
)))))
(
defun
failure-if
(
test
&rest
failure-args
)
"If not TEST, return success, otherwise, return failure with FAILURE-ARGS"
(
apply
'success-if
(
not
test
)
failure-args
))
(
defun
make-failure
(
&optional
reason
&rest
arguments
)
(
if
(
typep
reason
'execution-error
)
reason
(
make-condition
'execution-failure
:context
*execution-context*
:reason
(
apply
'make-error
reason
arguments
))))
(
defun
make-failures
(
&optional
list
)
(
make-condition
'execution-failures
:failures
list
))
(
defmacro
with-failure-context
((
&optional
context
)
&body
body
)
`
(
call-with-failure-context
(
lambda
()
,@
body
)
,
context
))
(
defun
register-failures
(
failure
)
(
let
((
failure
(
make-failure
failure
)))
(
etypecase
failure
(
execution-failures
(
setf
*failures*
(
append
(
failure-list
failure
)
*failures*
)))
(
execution-failure
(
push
failure
*failures*
)))
failure
))
(
defun
call-with-failure-context
(
thunk
context
)
(
let
((
toplevel
(
null
*execution-context*
))
(
*execution-context*
(
cons
context
*execution-context*
))
(
fail-fast
*fail-fast*
)
(
*fail-fast*
t
))
(
labels
((
compute
()
(
block
nil
(
handler-bind
((
error
(
lambda
(
c
)
(
register-failures
c
)
(
if
(
and
fail-fast
(
not
toplevel
))
(
error
(
make-failures
))
(
return
(
failure
))))))
(
funcall
thunk
))))
(
doit
()
(
let
((
results
(
multiple-value-list
(
compute
))))
(
if
(
and
toplevel
*failures*
)
(
failure
(
reverse
*failures*
))
(
apply
'success
results
)))))
(
if
toplevel
(
let
((
*failures*
nil
))
(
doit
))
(
doit
)))))
(
defmacro
without-stopping
(()
&body
body
)
`
(
call-without-stopping
,@
(
mapcar
(
lambda
(
form
)
`
(
lambda
()
,
form
))
body
)))
(
defun
call-without-stopping
(
&rest
thunks
)
(
let
((
failurep
nil
)
(
*fail-fast*
nil
))
(
dolist
(
thunk
thunks
)
(
when
(
failurep
(
multiple-value-list
(
with-failure-context
()
(
funcall
thunk
))))
(
setf
failurep
t
)))
(
failure-if
failurep
(
make-failures
))))
tools/git.lisp
View file @
a0317bc1
...
...
@@ -4,22 +4,15 @@
;; Note that the debian git at git://git.debian.org/git/pkg-common-lisp/cl-asdf.git is stale,
;; as we currently build directly from upstream at git://common-lisp.net/projects/asdf/asdf.git
(
defun
run*
(
cmd
&rest
keys
)
(
multiple-value-bind
(
out
err
code
)
(
apply
'run
cmd
keys
)
(
if
(
eql
0
code
)
(
success
)
(
values
nil
out
err
code
))))
(
defun
git
(
cmd
&rest
keys
)
(
with-asdf-dir
()
(
apply
'run*
(
cons
"git"
cmd
)
keys
)))
(
apply
'run*
`
(
git
,@
cmd
)
keys
)))
(
def
un
clean
()
(
def
testcmd
clean
()
"clean the checkout with git clean -xfd"
(
git
'
(
clean
-xfd
)))
(
def
un
%push
()
(
def
testcmd
%push
()
"push git branches master and release upstream"
(
dolist
(
x
'
((
status
)
(
push
--tags
cl.net
release
master
)
...
...
@@ -28,7 +21,7 @@
(
status
)))
(
git
x
)))
(
def
un
merge-master-into-release
()
(
def
testcmd
merge-master-into-release
()
"merge git branch master into release"
(
dolist
(
x
'
((
checkout
master
)
(
merge
release
)
...
...
@@ -43,17 +36,18 @@
"RELEASE"
"STABLE"
;; These were misguided attempts for what should have been branches
"README"
"emp"
))
;; Mistakes
(
def
un
fix-local-git-tags
()
(
def
testcmd
fix-local-git-tags
()
"delete wrongful tags from local git repository"
(
dolist
(
tag
*wrongful-tags*
)
(
git
`
(
tag
-d
,
tag
)
:on-error
nil
)))
(
without-stopping
()
(
dolist
(
tag
*wrongful-tags*
)
(
git
`
(
tag
-d
,
tag
)
:on-error
nil
))))
(
def
un
fix-remote-git-tags
(
&optional
(
remote
"origin"
))
(
def
testcmd
fix-remote-git-tags
(
(
remote
"origin"
))
"delete wrongful tags from remote git repository"
(
dolist
(
tag
*wrongful-tags*
)
(
git
`
(
push
,
remote
(
:refs/tags/,tag
))
:on-error
nil
)))
(
without-stopping
()
(
dolist
(
tag
*wrongful-tags*
)
(
git
`
(
push
,
remote
(
:refs/tags/,tag
))
:on-error
nil
))))
(
def
un
git-all-committed-p
()
(
def
testcmd
git-all-committed-p
()
"is your checkout clean, with all files committed?"
(
null
(
nth-value
1
(
git
'
(
status
-s
)
:output
:lines
))))
tools/install-asdf.lisp
View file @
a0317bc1
...
...
@@ -30,7 +30,7 @@ Note that if you're using it with LispWorks (known to only provide ASDF 2
as of LispWorks 6.1 in 2015), you first have to create a command-line
executable for LispWorks this way:
echo '(hcl:save-image "lispworks" :environment nil)' > si.lisp
echo '(hcl:save-image "lispworks
-console
" :environment nil)' > si.lisp
lispworks-6-1-0-x86-linux -siteinit - -init - -build si.lisp
|#
...
...
tools/main.lisp
View file @
a0317bc1
;;;; Generic code to interface a Lisp script to the shell command-line.
(
in-package
:asdf-tools
)
(
defun
success
(
&optional
(
success
t
))
"Return magic values that signal success (default), or failure depending on SUCCESS"
(
if
success
(
values
t
'
#:success
)
(
values
nil
'
#:failure
)))
(
defun
failure
()
"Return magic values that signal failure"
(
success
nil
))
(
defun
re
(
arg
)
"Read-Eval function (the RE of REPL)
(the Print and Loop parts are not here)"
...
...
@@ -52,7 +41,7 @@ Unless EARLYP is true, return NIL if the symbol is not fbound."
git-all-committed-p
bump-version
bump
;; version
test-load-systems
test-clean-load
test-basic
%load
install-asdf
;; test-basic
%
test
%t
test-scripts
;; test-scripts
test
%t
test-scripts
;; test-scripts
test-upgrade
u
extract-tagged-asdf
extract-all-tagged-asdf
extract
;; test-upgrade
test-all-clean-load
test-all-scripts
test-all-no-upgrade
test-all-upgrade
;; test-all
test-all
test-all-scripts-no-stop
test-all-upgrade-no-stop
...
...
@@ -99,20 +88,18 @@ based on a list of targets"
;;; Main entry point.
;;; NB: For access control, you could check that only exported symbols are used as entry points.
(
defun
process-arguments
(
args
)
(
block
nil
(
unless
args
(
format
t
"No command provided~%"
)
(
return
))
(
if-let
((
fun
(
find-command
(
first
args
))))
(
let
((
results
(
multiple-value-list
(
apply
fun
(
rest
args
)))))
;; Don't print anything on success for regular commands, otherwise print all values returned.
(
cond
((
equal
results
(
multiple-value-list
(
success
))))
((
equal
results
(
multiple-value-list
(
failure
)))
(
format
t
"~&Command failed.~%"
))
(
t
(
format
t
"~&~{~S~%~}"
results
)))
(
return
(
first
results
))))
(
format
t
"Command ~A not found~%"
(
first
args
))
(
return
nil
)))
(
if-let
((
fun
(
and
args
(
find-command
(
first
args
)))))
(
let
((
results
(
multiple-value-list
(
apply
fun
(
rest
args
)))))
;; Don't print anything on success for regular commands, otherwise print all values returned.
(
if
(
failurep
results
)
(
format
t
"~&Failure:~{~& ~A~}~&"
(
failure-failures
results
))
(
format
t
"~{~&~S~&~}"
(
if
(
successp
results
)
(
success-values
results
)
results
)))
(
apply
'values
results
))
(
progn
(
if
args
(
format
t
"Command ~A not found~%"
(
first
args
))
(
format
t
"No command provided~%"
))
nil
)))
;;; For a multi-call binary, use these cl-launch or buildapp arguments: --dispatch-entry asdf-tools/asdf-tools::main
(
defun
main
(
argv
)
...
...
tools/release.lisp
View file @
a0317bc1
...
...
@@ -31,39 +31,37 @@
(
defun
tarname
(
name
)
(
strcat
name
".tar.gz"
))
(
def
un
make-tarball-from-git
(
name
base
files
&key
(
type
"tar.gz"
))
(
def
testcmd
make-tarball-from-git
(
name
base
files
(
type
"tar.gz"
))
(
with-asdf-dir
(
base
)
(
let
((
tarball
(
strcat
name
"."
type
)))
(
run
`
(
git
archive
-o
,
(
pn
"build"
tarball
)
:prefix
(
,
name
/
)
,
*version*
--
,@
files
)
:show
t
)))
(
success
))
(
git
`
(
archive
-o
,
(
pn
"build"
tarball
)
:prefix
(
,
name
/
)
,
*version*
--
,@
files
)
:show
t
))))
(
def
un
make-tarball-from-git-plus
(
name
base
files
&key
asdf-lisp
version-file
)
(
def
testcmd
make-tarball-from-git-plus
(
name
base
files
asdf-lisp
version-file
)
;; make a tarball, then add build/asdf.lisp to it
(
make-tarball-from-git
name
base
files
:type
"tar"
)
(
make-tarball-from-git
name
base
files
"tar"
)
(
let*
((
tarball
(
strcat
name
".tar"
)))
(
with-asdf-dir
(
"build/"
)
(
when
asdf-lisp
(
build-asdf
)
(
ensure-directories-exist
(
pn
"build"
name
"build/"
))
(
run
`
(
cp
-a
asdf.lisp
(
,
name
/build/
)))
(
run
*
`
(
cp
-a
asdf.lisp
(
,
name
/build/
)))
;; TODO: find which tar it is and tell --uid 0 --gid 0 to BSD tar
;; and --owner root --group root to GNU tar,
;; falling back to nothing. Sigh.
(
run
`
(
env
"COPYFILE_DISABLE=1"
(
run
*
`
(
env
"COPYFILE_DISABLE=1"
tar
"-rf"
,
tarball
(
,
name
/build/asdf.lisp
))
:show
t
)
(
run
`
(
rm
-f
(
,
name
/build/asdf.lisp
)))
(
run
*
`
(
rm
-f
(
,
name
/build/asdf.lisp
)))
(
delete-empty-directory
(
pn
"build"
name
"build/"
)))
(
when
version-file
(
ensure-directories-exist
(
pn
"build"
name
""
))
(
run
`
(
cp
-a
..
/version.lisp-expr
(
,
name
/
)))
(
run
`
(
env
"COPYFILE_DISABLE=1"
(
run
*
`
(
cp
-a
..
/version.lisp-expr
(
,
name
/
)))
(
run
*
`
(
env
"COPYFILE_DISABLE=1"
tar
"-rf"
,
tarball
(
,
name
/version.lisp-expr
))
:show
t
)
(
run
`
(
rm
-f
(
,
name
/version.lisp-expr
))))
(
run
*
`
(
rm
-f
(
,
name
/version.lisp-expr
))))
(
let
((
dir
(
pn
"build"
name
""
)))
(
when
(
directory-exists-p
dir
)
(
delete-empty-directory
dir
)))
(
run
`
(
gzip
-f9
,
tarball
)
:show
t
)))
(
success
))
(
run*
`
(
gzip
-f9
,
tarball
)
:show
t
))))
(
defun
uiop-files
()
"list files in uiop"
...
...
@@ -74,7 +72,7 @@
(
make-tarball-from-git-plus
(
driver-name
)
"uiop/"
(
remove
"version.lisp-expr"
(
uiop-files
)
:test
'equal
)
:version-file
t
))
nil
t
))
(
defun
asdf-defsystem-files
()
...
...
@@ -96,19 +94,17 @@
(
defun
asdf-lisp-name
()
(
format
nil
"asdf-~A.lisp"
*version*
))
(
def
un
make-asdf-lisp
()
(
def
testcmd
make-asdf-lisp
()
(
build-asdf
)
(
concatenate-files
(
list
(
pn
"build/asdf.lisp"
))
(
pn
"build/"
(
asdf-lisp-name
)))
(
success
))
(
pn
"build/"
(
asdf-lisp-name
))))
(
def
un
make-archive
()
(
def
testcmd
make-archive
()
"build tarballs for release"
(
make-driver-tarball
)
(
make-asdf-defsystem-tarball
)
(
make-git-tarball
)
(
make-asdf-lisp
)
(
success
))
(
make-asdf-lisp
))
;;; Publishing tarballs onto the public repository
...
...
@@ -117,32 +113,30 @@
(
defvar
*clnet-asdf-public*
"/project/asdf/public_html/"
)
(
defun
public-path
(
x
)
(
strcat
*clnet-asdf-public*
x
))
(
def
un
publish-archive
()
(
def
testcmd
publish-archive
()
"publish tarballs to the website"
(
let
((
tarballs
(
mapcar
'tarname
(
list
(
driver-name
)
(
asdf-defsystem-name
)
(
asdf-git-name
)))))
(
run
`
(
rsync
"--times"
"--chmod=a+rX,ug+w"
,@
tarballs
,
(
asdf-lisp-name
)
(
,
*clnet*
":"
,
(
public-path
"archives/"
)))
:show
t
:directory
(
pn
"build/"
)))
(
run
*
`
(
rsync
"--times"
"--chmod=a+rX,ug+w"
,@
tarballs
,
(
asdf-lisp-name
)
(
,
*clnet*
":"
,
(
public-path
"archives/"
)))
:show
t
:directory
(
pn
"build/"
)))
(
format
t
"~&To download the tarballs, point your browser at:~%
http://common-lisp.net/project/asdf/archives/
~%"
)
(
success
))
~%"
))
(
def
un
link-archive
()
(
def
testcmd
link-archive
()
"symlink new tarballs on the website"
(
run
(
format
nil
"ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S"
(
tarname
(
driver-name
))
(
public-path
"archives/uiop.tar.gz"
)
(
tarname
(
asdf-defsystem-name
))
(
public-path
"archives/asdf-defsystem.tar.gz"
)
(
tarname
(
asdf-git-name
))
(
public-path
"archives/asdf.tar.gz"
)
(
asdf-lisp-name
)
(
public-path
"archives/asdf.lisp"
))
:show
t
:host
*clnet*
)
(
success
))
(
defun
make-and-publish-archive
()
(
run*
(
format
nil
"ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S"
(
tarname
(
driver-name
))
(
public-path
"archives/uiop.tar.gz"
)
(
tarname
(
asdf-defsystem-name
))
(
public-path
"archives/asdf-defsystem.tar.gz"
)
(
tarname
(
asdf-git-name
))
(
public-path
"archives/asdf.tar.gz"
)
(
asdf-lisp-name
)
(
public-path
"archives/asdf.lisp"
))
:show
t
:host
*clnet*
))
(
deftestcmd
make-and-publish-archive
()
"make and publish tarballs"
(
make-archive
)
(
publish-archive
)
...
...
@@ -153,7 +147,7 @@
;;; Making a debian package
(
def
un
debian-package
(
&optional
(
release
"release"
))
(
def
testcmd
debian-package
(
(
release
"release"
))
"build a debian package"
(
let*
((
debian-version
(
debian-version-from-file
release
))
(
version
(
version-from-file
release
)))
...
...
@@ -161,23 +155,22 @@
(
error
"Debian version ~A doesn't match asdf version ~A"
debian-version
version
))
(
clean
)
(
format
t
"building package version ~A~%"
(
debian-version-from-file
))
(
run
`
(
git-buildpackage
;; --git-ignore-new ;; for testing purpose
(
--git-debian-branch=
,
release
)
(
--git-upstream-tag=
"%(version)s"
)
;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag
;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag
--git-tag
--git-retag
;; --git-no-pristine-tar
--git-force-create
--git-ignore-branch
)
:directory
(
pn
)
:show
t
))
(
success
))
(
run*
`
(
git-buildpackage
;; --git-ignore-new ;; for testing purpose
(
--git-debian-branch=
,
release
)
(
--git-upstream-tag=
"%(version)s"
)
;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag
;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag
--git-tag
--git-retag
;; --git-no-pristine-tar
--git-force-create
--git-ignore-branch
)
:directory
(
pn
)
:show
t
)))
(
defun
debian-architecture
()
(
run/ss
`
(
dpkg
--print-architecture
)))
(
def
un
publish-debian-package
(
&optional
release
)
(
def
testcmd
publish-debian-package
(
release
)
"publish a debian package"
(
let
((
changes
(
strcat
"cl-asdf_"
(
debian-version-without-epoch
(
debian-version-from-file
release
))
"_"
(
debian-architecture
)
".changes"
)))
...
...
@@ -214,5 +207,4 @@
(
when
releasep
(
log!
log
t
"Don't forget to send a debian mentors request!"
))
(
log!
log
"Don't forget to send announcement to asdf-announce, asdf-devel, etc."
)
(
log!
log
"Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad"
))))
(
success
))
(
log!
log
"Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad"
)))))
tools/test-all.lisp
View file @
a0317bc1
(
in-package
:asdf-tools
)
(
defun
call-with-all-lisps
(
thunk
&optional
(
lisps
*test-lisps*
))
(
apply
'all-pass
(
loop
:for
lisp
:in
(
get-lisps
lisps
)
:collect
(
funcall
thunk
lisp
))))
(
defun
call-with-all-lisps
(
thunk
&key
(
lisps
*test-lisps*
)
(
fail-fast
t
))
(
let
((
thunks
(
loop
:for
lisp
:in
(
get-lisps
lisps
)
:collect
(
lambda
()
(
with-failure-context
((
format
nil
"using ~(~A~)"
lisp
))
(
funcall
thunk
lisp
))))))
(
if
fail-fast
(
progn
(
map
()
'funcall
thunks
)
(
success
))
(
apply
'call-without-stopping
thunks
))))
(
defmacro
with-all-lisps
((
&optional
(
lisp-var
'lisp
)
(
lisps
'*test-lisps*
))
&body
body
)
`
(
call-with-all-lisps
(
lambda
(
,
lisp-var
)
,@
body
)
,
lisps
))
(
defmacro
with-all-lisps
((
lisp-var
lisps
&key
(
fail-fast
t
))
&body
body
)
`
(
call-with-all-lisps
(
lambda
(
,
lisp-var
)
,@
body
)
:lisps
,
lisps
:fail-fast
,
fail-fast
))
(
deftestcmd
test-all-clean-load
(
lisps
)
"test-clean-load on all lisps"
...
...
@@ -18,7 +22,7 @@
(
deftestcmd
test-all-no-upgrade
()
"test-basic, and test-all-script"
(
all-pass
(
test-basic
)
(
test-all-scripts
)
))
(
test-basic
)
(
test-all-scripts
))
(
deftestcmd
test-all-upgrade
(
upgrade-lisps
)
"test-upgrade on all lisps"
...
...
@@ -26,58 +30,56 @@
(
deftestcmd
test-all
()
"all tests"
(
all-pass
(
test-all-no-upgrade
)
(
test-all-upgrade
)
))
(
test-all-no-upgrade
)
(
test-all-upgrade
))
(
deftestcmd
test-all-scripts-no-stop
(
lisps
)
"test-scripts on all lisps, no stop"
(
with-all-lisps
(
l
lisps
)
(
ignore-errors
(
test-scripts
l
)
)))
(
with-all-lisps
(
l
lisps
:fail-fast
nil
)
(
test-scripts
l
)))
(
deftestcmd
test-all-upgrade-no-stop
(
upgrade-lisps
)
"test-upgrade on all lisps, no stop"
(
with-all-lisps
(
l
upgrade-lisps
)
(
ignore-errors
(
test-upgrade
l
)
)))
(
with-all-lisps
(
l
upgrade-lisps
:fail-fast
nil
)
(
test-upgrade
l
)))
(
deftestcmd
test-all-no-upgrade-no-stop
()
"all tests but upgrade on all lisps, no stop"
(
all-pass
(
doc
)
(
test-load-systems
)
(
test-all-clean-load
)
(
test-all-scripts-no-stop
)
(
check-all-scripts-results
)))
(
without-stopping
()
(
doc
)
(
test-load-systems
)
(
test-all-clean-load
)
(
test-all-scripts-no-stop
)
(
check-all-scripts-results
)))
(
deftestcmd
test-all-no-stop
()
;; TODO: pass arguments!
"all tests on all lisps, no stop"
(
all-pass