Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
08149c40
Commit
08149c40
authored
Jan 27, 2010
by
Francois-Rene Rideau
Browse files
Merge branch 'master' of
ssh://frideau@common-lisp.net/project/xcvb/git/asdf
parents
31c47c52
7c184ec6
Changes
3
Hide whitespace changes
Inline
Side-by-side
.gitignore
View file @
08149c40
...
...
@@ -7,6 +7,7 @@ website/changelog.xml
# Test stuff
test/results/
test/tmp/
# We build these at various stages in the make process
LICENSE
...
...
test/run-tests.sh
View file @
08149c40
...
...
@@ -5,7 +5,8 @@
# - quit with exit status 0 on getting eof
# - quit with exit status >0 if an unhandled error occurs
export
CL_SOURCE_REGISTRY
=
$PWD
export
TEST_DIR
=
"
$PWD
/tmp/"
export
CL_SOURCE_REGISTRY
=
"
$TEST_DIR
/dir1/:
$TEST_DIR
/dir2//"
if
[
x
"
$1
"
=
"xhelp"
]
;
then
echo
"
$0
[lisp invocation] [scripts-regex]"
...
...
@@ -105,6 +106,15 @@ fi
# do_tests "/usr/bin/lisp -batch -noinit" x86f
#fi
create_asds
()
{
mkdir
-p
tmp/
{
dir1,dir2/
{
dir3,dir4
}}
for
i
in
`
find tmp |
sed
-e
'1d'
`
;
do
touch
"
$i
"
/test.asd
;
done
}
clean_up
()
{
rm
-rf
tmp
}
if
[
-z
"
$command
"
]
;
then
echo
"Error: cannot find or do not know how to run Lisp named
$lisp
"
...
...
test/test-source-registry.s
View file @
08149c40
...
...
@@ -2,120 +2,47 @@
(
load
"../
asdf
")
;; TODO:
;; - test for conditions
;; - use with-env for CL_SOURCE_REGISTRY
;; - write clean-up procedures, if needed
;; - test for directories
;; - test for correct chaining of inheritance
(
eval
-
when
(:
execute
:
compile
-
toplevel
:
load
-
toplevel
)
(
require
:
sb
-
posix
))
(
defun
pathname
->
directory
(
pathname
)
(
make
-
pathname
:
directory
(
append
(
pathname
-
directory
pathname
)
(
list
(
file
-
namestring
pathname
)))
:
name
nil
:
type
nil
:
defaults
(
pathname
pathname
)))
(
def
package
:
test
-
source
-
regist
ry
(
:
use
#
:
cl
#
:
asdf
))
(
def
var
*
test
-
directo
ry
*
(
pathname
->
directory
(
getenv
"TEST_DIR"
)
))
(
in
-
package
:
test
-
source
-
registry
)
(
defun
under
-
test
-
directory
(
path
&
optional
(
defaults
*
test
-
directory
*))
(
merge
-
pathnames
path
defaults
))
(
defun
getenv
(
x
)
#+
sbcl
(
sb
-
posix
:
getenv
x
))
(
defun
setenv
(
x
v
)
#+
sbcl
(
sb
-
posix
:
putenv
(
concatenate
'string x "=" v))
v
)
(
defmacro
with
-
gensyms
((&
rest
names
)
&b
ody
body
)
`(
let
,(
loop
for
n
in
names
collect
`
(,
n
(
gensym
)))
,@
body
))
(
defmacro
with
-
env
((&
rest
kv
)
&b
ody
body
)
(
let
((
temps
(
loop
:
for
i
:
upto
(
length
kv
)
:
collect
(
gensym
)))
(
keys
(
mapcar
#
'(lambda (x) (first x)) kv)))
(
flet
((
gen
-
getenvs
()
(
mapcar
#
'(lambda (x y)
`(,
y
(
getenv
,
x
)))
keys
temps
))
(
gen
-
setenvs
()
(
mapcar
#
'(lambda (x y) `(setenv ,y ,x))
temps
keys
)))
`(
let
,(
gen
-
getenvs
)
(
unwind
-
protect
(
progn
,@(
loop
:
for
(
k
v
)
:
in
kv
:
collect
`
(
setenv
,
k
,
v
))
,@
body
)
(
progn
,
@
(
gen
-
setenvs
)))))))
(
defun
make
-
temporary
-
directory
()
(
let
((
str
(
with
-
output
-
to
-
string
(
s
)
(
sb
-
ext
:
run
-
program
"mktemp"
'("-d" "-u") :search t :output s))))
(
concatenate
'string
(
string
-
trim
'(#\newline) str) "/")))
(
defvar
*
base
-
directory
*
(
make
-
temporary
-
directory
))
(
defun
home
-
directory
(&
optional
(
base
*
base
-
directory
*))
(
let
((
s
(
namestring
(
user
-
homedir
-
pathname
))))
(
merge
-
pathnames
(
subseq
s
1
(
length
s
))
base
)))
(
defun
system
-
directory
(&
optional
(
base
*
base
-
directory
*))
(
merge
-
pathnames
"etc/"
base
))
(
defun
tmp
-
directory
(&
optional
(
base
*
base
-
directory
*))
(
merge
-
pathnames
"tmp/"
base
))
(
defun
home
-
source
-
registry
()
(
asdf
::
source
-
registry
-
under
(
merge
-
pathnames
".config/"
(
home
-
directory
))))
(
defun
system
-
source
-
registry
()
(
asdf
::
source
-
registry
-
under
(
system
-
directory
)))
(
defun
merge
-
temp
-
under
(
path
)
(
namestring
(
merge
-
pathnames
(
let
((
s
(
string
-
downcase
(
prin1
-
to
-
string
(
gentemp
)))))
(
concatenate
'string s "/"))
path
)))
(
defvar
*
asd
-
temp
-
path
-1
*
(
merge
-
temp
-
under
(
merge
-
temp
-
under
(
tmp
-
directory
))))
(
defvar
*
system
-
source
-
registry
-
config
*
`(:
source
-
registry
(:
inherit
-
configuration
)
(:
tree
,*
asd
-
temp
-
path
-
1
*)))
(
defvar
*
asd
-
temp
-
path
-2
*
(
namestring
(
tmp
-
directory
)))
(
defvar
*
home
-
source
-
registry
-
config
*
(
defvar
*
test
-
config
-1
*
`(:
source
-
registry
(:
inhert
-
configuration
)
(:
directory
,(
namestring
(
tmp
-
directory
)))))
(
defun
write
-
registry
-
file
(
path
contents
)
(
ensure
-
directories
-
exist
path
)
(
with
-
open
-
file
(
out
path
:
direction
:
output
:
if
-
exists
:
supersede
)
(
with
-
standard
-
io
-
syntax
(
format
out
"~S"
contents
))))
(
defun
write
-
system
-
source
-
registry
-
config
(&
key
(
path
(
system
-
source
-
registry
))
(
contents
*
system
-
source
-
registry
-
config
*))
(
write
-
registry
-
file
path
contents
))
(
defun
write
-
home
-
source
-
registry
-
config
(&
key
(
path
(
home
-
source
-
registry
))
(
contents
*
home
-
source
-
registry
-
config
*))
(
write
-
registry
-
file
path
contents
))
;; use *asd-temp-path-X*?
(
defun
create
-
asd
-
file
(&
optional
(
directory
*
default
-
pathname
-
defaults
*))
(
let
((*
default
-
pathname
-
defaults
*
directory
))
(
with
-
open
-
file
(
out
;; test environment variable
(
defun
test
-
environment
()
(
with
-
env
-
var
((
"CL_SOURCE_REGISTRY"
(
format
nil
"~A:~A"
(
home
-
directory
)
(
system
-
directory
))))
...))
;; test files
(
defun
test
-
files
()
...)
;; (cl-user::quit-on-error
;; ...)
\ No newline at end of file
(:
directory
,(
namestring
(
under
-
test
-
directory
"dir1/"
)))
(:
tree
,(
namestring
(
under
-
test
-
directory
"dir2/"
)))
(:
ignore
-
inherited
-
configuration
)))
(
defvar
*
test
-
expect
-1
*
(
loop
:
for
dir
:
in
'("dir1/" "dir2/dir3/" "dir2/dir4/" "dir2/")
:
collect
(
merge
-
pathnames
dir
*
test
-
directory
*)))
(
defvar
*
test
-
source
-
registries
*
'(
test
-
environment
-
source
-
registry
test
-
something
-2
test
-
something
-3))
(
cl
-
user
::
quit
-
on
-
error
(
assert
(
equal
(
process
-
source
-
registry
(
getenv
"CL_SOURCE_REGISTRY"
))
*
test
-
expect
-1*))
(
assert
(
equal
(
process
-
source
-
registry
*
test
-
config
-1*)
*
test
-
expect
-1*))
;; FIXME: add more tests
;; (assert (equal ...))
)
\ No newline at end of file
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment