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
072692f1
Commit
072692f1
authored
Jan 18, 2013
by
Francois-Rene Rideau
Browse files
2.26.119: conditionalize all truenaming on *resolve-symlinks*.
jyknight will be happy. Passes test, when still resolving.
parent
5e8f210c
Changes
29
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
072692f1
...
...
@@ -38,17 +38,17 @@ XCL ?= xcl
header_lisp
:=
header.lisp
driver_lisp
:=
package.lisp compatibility.lisp utility.lisp pathname.lisp stream.lisp os.lisp image.lisp run-program.lisp lisp-build.lisp configuration.lisp backward-driver.lisp driver.lisp
asdf
_lisp
:=
upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
defsystem
_lisp
:=
upgrade.lisp component.lisp system.lisp find-system.lisp find-component.lisp operation.lisp action.lisp lisp-action.lisp plan.lisp operate.lisp output-translations.lisp source-registry.lisp backward-internals.lisp defsystem.lisp bundle.lisp concatenate-source.lisp backward-interface.lisp interface.lisp footer.lisp
# Making ASDF itself should be our first, default, target:
build/asdf.lisp
:
$(wildcard *.lisp)
mkdir
-p
build
cat
$(header_lisp)
$(driver_lisp)
$(
asdf
_lisp)
>
$@
cat
$(header_lisp)
$(driver_lisp)
$(
defsystem
_lisp)
>
$@
# This quickly locates such mistakes as unbalanced parentheses:
load
:
build/asdf.lisp
rlwrap sbcl
\
`
for
i
in
$(driver_lisp)
$(
asdf
_lisp)
;
do
echo
--load
$$
i
;
done
`
\
`
for
i
in
$(driver_lisp)
$(
defsystem
_lisp)
;
do
echo
--load
$$
i
;
done
`
\
--eval
'(in-package :asdf)'
install
:
archive-copy
...
...
@@ -60,10 +60,13 @@ bump-version: build/asdf.lisp
driver-files
:
@
echo
$(driver_lisp)
defsystem-files
:
@
echo
$(defsystem_lisp)
archive
:
build/asdf.lisp
#
${SBCL}
--userinit
/dev/null
--sysinit
/dev/null
--load
bin/make-helper.lisp
\
# --eval "
(
rewrite-license
)
" --eval "
(
quit
)
"
./bin/asdf-builder make-
tarballs
./bin/asdf-builder make-
and-publish-archive
archive-copy
:
archive build/asdf.lisp
git checkout release
...
...
@@ -76,9 +79,9 @@ archive-copy: archive build/asdf.lisp
### Count lines separately for asdf-driver and asdf itself:
wc
:
@
wc
$(driver_lisp)
|
sort
-n
;
echo
;
\
wc
$(header_lisp)
$(
asdf
_lisp)
|
sort
-n
;
\
wc
$(header_lisp)
$(
defsystem
_lisp)
|
sort
-n
;
\
echo
;
\
wc
$(driver_lisp)
$(
asdf
_lisp)
|
tail
-n
1
wc
$(header_lisp)
$(driver_lisp)
$(
defsystem
_lisp)
|
tail
-n
1
push
:
git status
...
...
action.lisp
View file @
072692f1
...
...
@@ -113,9 +113,9 @@ You can put together sentences using this phrase."))
;; 1- Make sure we have absolute pathnames
(
let*
((
directory
(
pathname-directory-pathname
(
component-pathname
component
)))
(
absolute-pathnames
(
loop
:for
pathname
:in
pathnames
:collect
(
ensure-
pathname
(
subpathname
directory
pathname
)
:want
-absolute
t
))))
(
loop
:for
pathname
:in
pathname
s
:collect
(
ensure-
pathname-absolute
pathname
directory
))))
;; 2- Translate those pathnames as required
(
if
fixedp
absolute-pathnames
...
...
asdf.asd
View file @
072692f1
...
...
@@ -15,7 +15,7 @@
:licence
"MIT"
:description
"Another System Definition Facility"
:long-description
"ASDF builds Common Lisp software organized into defined systems."
:version
"2.26.11
8
"
;; to be automatically updated by bin/bump-revision
:version
"2.26.11
9
"
;; to be automatically updated by bin/bump-revision
:depends-on
()
:components
((
:module
"build"
:components
((
:file
"asdf"
))))
:in-order-to
(
#+
asdf2.27
(
compile-op
(
monolithic-load-concatenated-source-op
generate-asdf
))))
...
...
bin/asdf-builder
View file @
072692f1
...
...
@@ -20,7 +20,7 @@
(defvar *asdf-dir*
(ensure-pathname (system-relative-pathname :asdf ())
:want-physical t :want-absolute t
:want-existing t :
ensure-
truename t))
:want-existing t :truename t))
(defparameter /asdf-dir/
(native-namestring *asdf-dir*))
(defun apath (x &rest keys) (apply 'subpathname *asdf-dir* x keys))
...
...
@@ -34,6 +34,7 @@
:ensure-subpath t))
(defparameter /build-dir/
(native-namestring *build-dir*))
(defun bpath (x &rest keys) (apply 'subpathname *build-dir* x keys))
(defparameter *version*
(safe-read-file-form
...
...
@@ -65,11 +66,6 @@
(defun tarname (name) (strcat name ".tar.gz"))
(defun run-program* (x)
(format t "~A~%" x)
(run-program/ x)
(values))
(defun make-tarball-under-build (name base files)
(check-type name string)
(ensure-pathname base :want-absolute t :want-existing t :want-directory t)
...
...
@@ -80,7 +76,7 @@
(ensure-pathname
base
:want-absolute t :want-directory t
:want-existing t :
ensure-
truename t)))
:want-existing t :truename t)))
(destination
(ensure-pathname
name
...
...
@@ -104,12 +100,12 @@
(error "Destination ~S already exists, not taking chances - you can delete it yourself."
destination))
(ensure-directories-exist destination)
(run
-program*
(format nil "cd ~S && cp -lax --parents ~{~S ~} ~S"
/base/ /files/ /destination/))
(run
-program*
(format nil "tar zcfC ~S ~S ~S/"
/tarball/ /build-dir/ name))
(run
-program*
`("rm" "-rf" ,/destination/)
)
)
(values))
(run (format nil "cd ~S && cp -lax --parents ~{~S ~} ~S"
/base/ /files/ /destination/)
:show t
)
(run (format nil "tar zcfC ~S ~S ~S/"
/tarball/ /build-dir/ name)
:show t
)
(run `("rm" "-rf" ,/destination/)
:show t
)
(values))
)
(defun driver-files ()
(list* "asdf-driver.asd" "version.lisp-expr"
...
...
@@ -123,7 +119,7 @@
(list* "asdf.asd" "build/asdf.lisp" "version.lisp-expr" "header.lisp"
(system-source-files :asdf/defsystem)))
(defun asdf-defsystem-name ()
(format nil "asdf-system-~A" *version*))
(format nil "asdf-
def
system-~A" *version*))
(defun make-asdf-defsystem-tarball ()
(build-asdf)
(make-tarball-under-build (asdf-defsystem-name) *asdf-dir* (asdf-defsystem-files)))
...
...
@@ -132,28 +128,47 @@
(format nil "asdf-~A" *version*))
(defun make-git-tarball ()
(build-asdf)
(run
-program*
(format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)"
/asdf-dir/ (asdf-git-name)))
(run (format nil "cd ~S && tar zcf build/~A.tar.gz build/asdf.lisp $(git ls-files)"
/asdf-dir/ (asdf-git-name))
:show t
)
(values))
(defun make-tarballs ()
(defun asdf-lisp-name ()
(format nil "asdf-~A.lisp" *version*))
(defun make-asdf-lisp ()
(build-asdf)
(concatenate-files (list (apath "build/asdf.lisp"))
(bpath (asdf-lisp-name))))
(defun make-archive ()
(make-driver-tarball)
(make-asdf-system-tarball)
(make-asdf-
def
system-tarball)
(make-git-tarball)
(make-asdf-lisp)
(values))
(defun publish-tarballs ()
(defvar *clnet* "clnet")
(defvar *clnet-asdf-public* "/project/asdf/public_html/")
(defun publish-archive ()
(let ((tarballs (mapcar 'tarname (list (driver-name) (asdf-defsystem-name) (asdf-git-name)))))
(run
-program*
(format nil "cd ~S && rsync ~{~S ~}clnet:/project/asdf/public_html/archives/"
/build-dir/ tarballs
)
))
(run (format nil "cd ~S && rsync ~{~S ~}
~S
clnet:/project/asdf/public_html/archives/"
/build-dir/ tarballs
(asdf-lisp-name)) :show t
))
(format t "~&To download the tarballs, point your browser at:~%
http://common-lisp.net/project/asdf/archives/
~%")
(values))
(defun make-and-publish-tarballs ()
(make-tarballs)
(publish-tarballs))
(defun link-archive ()
(run `(ln -sf ,(tarname (driver-name))
(,*clnet-asdf-public* "archives/asdf-driver.tar.gz"))
:show t :host *clnet*)
(values))
(defun make-and-publish-archive ()
(make-archive)
(publish-archive)
(link-archive))
(defparameter *versioned-files*
'(("version.lisp-expr" "\"" "\"")
...
...
@@ -248,7 +263,8 @@
(build-asdf)))
(defun git-version ()
(first (run-program/ '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :output :lines)))
(first (run '("git" "describe" "--tags" "--match" "[0-9].[0-9][0-9]") :output :lines
:show t)))
;;;; Main entry point
...
...
bundle.lisp
View file @
072692f1
...
...
@@ -337,7 +337,7 @@
(
files
(
and
system
(
output-files
operation
system
))))
(
if
(
or
move-here
(
and
(
null
move-here-p
)
(
member
operation-name
'
(
:program
:binary
))))
(
loop
:with
dest-path
=
(
truename
*
(
ensure-directories-exist
move-here-path
))
(
loop
:with
dest-path
=
(
resolve-symlinks
*
(
ensure-directories-exist
move-here-path
))
:for
f
:in
files
:for
new-f
=
(
make-pathname
:name
(
pathname-name
f
)
:type
(
pathname-type
f
)
...
...
defsystem.lisp
View file @
072692f1
...
...
@@ -32,10 +32,16 @@
;; and may be from within the EVAL-WHEN of a file compilation.
;; If no absolute pathname was found, we return NIL.
(
check-type
pathname
(
or
null
string
pathname
))
(
or
(
and
(
pathnamep
pathname
)
(
absolute-pathname-p
pathname
)
(
resolve-symlinks*
pathname
))
(
let*
((
load-pathname
(
resolve-symlinks*
(
load-pathname
))))
(
when
(
absolute-pathname-p
load-pathname
)
(
subpathname
load-pathname
pathname
:type
:directory
)))))
(
or
(
and
(
absolute-pathname-p
pathname
)
(
resolve-symlinks*
pathname
))
(
let*
((
load-pathname
(
load-pathname
))
(
load-absolute
(
or
(
absolute-pathname-p
load-pathname
)
(
let
((
defaults
(
resolve-symlinks*
*default-pathname-defaults*
)))
(
and
(
absolute-pathname-p
defaults
)
(
merge-pathnames*
load-pathname
defaults
))))))
(
when
(
absolute-pathname-p
load-absolute
)
(
resolve-symlinks*
(
subpathname
load-absolute
pathname
:type
:directory
))))))
;;; Component class
...
...
find-system.lisp
View file @
072692f1
...
...
@@ -148,14 +148,14 @@ which evaluates to a pathname. For example:
#p\"/home/me/cl/systems/\"
#p\"/usr/share/common-lisp/systems/\"))
This is for backward compatibili
l
y.
This is for backward compatibili
t
y.
Going forward, we recommend new users should be using the source-registry.
"
)
(
defun*
probe-asd
(
name
defaults
)
(
defun*
probe-asd
(
name
defaults
&key
truename
)
(
block
nil
(
when
(
directory-pathname-p
defaults
)
(
let*
((
file
(
probe-file*
(
subpathname
defaults
name
:type
"asd"
))))
(
let*
((
file
(
probe-file*
(
subpathname
defaults
name
:type
"asd"
)
:truename
truename
)))
(
when
file
(
return
file
)))
#-
(
or
clisp
genera
)
; clisp doesn't need it, plain genera doesn't have read-sequence(!)
...
...
@@ -177,10 +177,12 @@ Going forward, we recommend new users should be using the source-registry.
(
block
nil
(
unwind-protect
(
dolist
(
dir
*central-registry*
)
(
let
((
defaults
(
eval
dir
)))
(
let
((
defaults
(
resolve-symlinks*
(
eval
dir
)))
directorized
truenamized
)
(
when
defaults
(
cond
((
directory-pathname-p
defaults
)
(
let
((
file
(
probe-asd
name
defaults
)))
(
cond
((
and
(
directory-pathname-p
defaults
)
(
absolute-pathname-p
defaults
))
(
let*
((
file
(
probe-asd
name
defaults
:truename
*resolve-symlinks*
)))
(
when
file
(
return
file
))))
(
t
...
...
@@ -188,17 +190,29 @@ Going forward, we recommend new users should be using the source-registry.
(
let*
((
*print-circle*
nil
)
(
message
(
format
nil
(
compatfmt
"~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>"
)
(
compatfmt
"~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a
n absolute
directory.~@:>"
)
system
dir
defaults
)))
(
error
message
))
(
remove-entry-from-registry
()
:report
"Remove entry from *central-registry* and continue"
(
push
dir
to-remove
))
(
coerce-to-truename
()
:test
(
lambda
(
c
)
(
declare
(
ignore
c
))
(
setf
truenamized
(
truename*
defaults
)))
:report
(
lambda
(
s
)
(
format
s
(
compatfmt
"~@<Coerce entry to truename ~S and continue.~@:>"
)
truenamized
))
(
push
dir
to-remove
))
(
coerce-entry-to-directory
()
:test
(
lambda
(
c
)
(
declare
(
ignore
c
))
(
and
(
not
(
directory-pathname-p
defaults
))
(
directory-pathname-p
(
setf
directorized
(
ensure-directory-pathname
defaults
)))))
:report
(
lambda
(
s
)
(
format
s
(
compatfmt
"~@<Coerce entry to ~a, replace ~a and continue.~@:>"
)
(
ensure-directory-pathname
defaults
)
dir
))
(
push
(
cons
dir
(
ensure-directory-pathname
defaults
)
)
to-replace
))))))))
directorized
dir
))
(
push
(
cons
dir
directorized
)
to-replace
))))))))
;; cleanup
(
dolist
(
dir
to-remove
)
(
setf
*central-registry*
(
remove
dir
*central-registry*
)))
...
...
header.lisp
View file @
072692f1
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.11
8
: Another System Definition Facility.
;;; This is ASDF 2.26.11
9
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
output-translations.lisp
View file @
072692f1
...
...
@@ -138,7 +138,8 @@ and the order is by decreasing length of namestring of the source pathname.")
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
#+
(
or
#|clozure|#
ecl
mkcl
sbcl
)
,@
(
let
((
h
(
lisp-implementation-directory
:truename
t
)))
(
when
h
`
(((
,
h
,
*wild-path*
)
()))))
,@
(
let
((
h
(
resolve-symlinks*
(
lisp-implementation-directory
))))
(
when
h
`
(((
,
h
,
*wild-path*
)
()))))
#+
mkcl
(
,
(
translate-logical-pathname
"CONTRIB:"
)
())
;; All-import, here is where we want user stuff to be:
:inherit-configuration
...
...
@@ -187,7 +188,7 @@ and the order is by decreasing length of namestring of the source pathname.")
(
when
src
(
let
((
trusrc
(
or
(
eql
src
t
)
(
let
((
loc
(
resolve-location
src
:ensure-directory
t
:wilden
t
)))
(
if
(
absolute-pathname-p
loc
)
(
truenamize
loc
)
loc
)))))
(
if
(
absolute-pathname-p
loc
)
(
resolve-symlinks*
loc
)
loc
)))))
(
cond
((
location-function-p
dst
)
(
funcall
collect
...
...
@@ -213,7 +214,7 @@ and the order is by decreasing length of namestring of the source pathname.")
((
directory-pathname-p
pathname
)
(
process-output-translations
(
validate-output-translations-directory
pathname
)
:inherit
inherit
:collect
collect
))
((
probe-file*
pathname
)
((
probe-file*
pathname
:truename
*resolve-symlinks*
)
(
process-output-translations
(
validate-output-translations-file
pathname
)
:inherit
inherit
:collect
collect
))
(
t
...
...
@@ -260,13 +261,13 @@ effectively disabling the output translation facility."
(
initialize-output-translations
)))
(
defun*
apply-output-translations
(
path
)
#+
cormanlisp
(
truenamize
path
)
#-
cormanlisp
#+
cormanlisp
(
resolve-symlinks*
path
)
#-
cormanlisp
(
etypecase
path
(
logical-pathname
path
)
((
or
pathname
string
)
(
ensure-output-translations
)
(
loop
:with
p
=
(
truenamize
path
)
(
loop
:with
p
=
(
resolve-symlinks*
path
)
:for
(
source
destination
)
:in
(
car
*output-translations*
)
:for
root
=
(
when
(
or
(
eq
source
t
)
(
and
(
pathnamep
source
)
...
...
pathname.lisp
View file @
072692f1
...
...
@@ -23,7 +23,7 @@
#:component-name-to-pathname-components
#:split-name-type
#:parse-unix-namestring
#:unix-namestring
#:split-unix-namestring-directory-components
#:subpathname
#:subpathname*
#:subpathname
#:subpathname*
#:subpathp
;; Resolving symlinks somewhat
#:truenamize
#:resolve-symlinks
#:resolve-symlinks*
;; Wildcard pathnames
...
...
@@ -362,27 +362,35 @@ Returns the (parsed) PATHNAME when true"
(
defun*
truename*
(
p
)
;; avoids both logical-pathname merging and physical resolution issues
(
ignore-errors
(
with-pathname-defaults
()
(
truename
p
))))
(
and
p
(
ignore-errors
(
with-pathname-defaults
()
(
truename
p
))))
)
(
defun*
probe-file*
(
p
)
"when given a pathname P, probes the filesystem for a file or directory
with given pathname and if it exists return its truename."
(
defun*
probe-file*
(
p
&key
truename
)
"when given a pathname P (designated by a string as per PARSE-NAMESTRING),
probes the filesystem for a file or directory with given pathname.
If it exists, return its truename is ENSURE-PATHNAME is true,
or the original (parsed) pathname if it is false (the default)."
(
with-pathname-defaults
()
;; avoids logical-pathname issues on some implementations
(
etypecase
p
(
null
nil
)
(
string
(
probe-file*
(
parse-namestring
p
)))
(
string
(
probe-file*
(
parse-namestring
p
)
:truename
truename
))
(
pathname
(
unless
(
wild-pathname-p
p
)
#.
(
or
#+
(
or
allegro
clozure
cmu
cormanlisp
ecl
lispworks
mkcl
sbcl
scl
)
'
(
probe-file
p
)
#+
clisp
(
if-let
(
it
(
find-symbol*
'
#:probe-pathname
:ext
nil
))
`
(
ignore-errors
(
,
it
p
)))
#+
gcl<2.7
'
(
or
(
probe-file
p
)
(
and
(
directory-pathname-p
p
)
(
ignore-errors
(
ensure-directory-pathname
(
truename*
(
subpathname
(
ensure-directory-pathname
p
)
"."
))))))
'
(
truename*
p
)))))))
(
let
((
foundtrue
#.
(
or
#+
(
or
allegro
clozure
cmu
cormanlisp
ecl
lispworks
mkcl
sbcl
scl
)
'
(
probe-file
p
)
#+
clisp
(
if-let
(
it
(
find-symbol*
'
#:probe-pathname
:ext
nil
))
`
(
ignore-errors
(
,
it
p
)))
#+
gcl<2.7
'
(
or
(
probe-file
p
)
(
and
(
directory-pathname-p
p
)
(
ignore-errors
(
ensure-directory-pathname
(
truename*
(
subpathname
(
ensure-directory-pathname
p
)
"."
))))))
'
(
truename*
p
))))
(
cond
(
truename
foundtrue
)
(
foundtrue
p
)
(
t
nil
))))))))
(
defun*
safe-file-write-date
(
pathname
)
;; If FILE-WRITE-DATE returns NIL, it's possible that
...
...
@@ -597,8 +605,8 @@ even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
to throw an error if the pathname is absolute"
(
block
nil
(
check-type
type
(
or
null
string
(
eql
:directory
)))
(
when
(
eq
type
:
directory
)
(
setf
ensure-
directory
t
))
(
when
ensure-
directory
(
setf
type
:
directory
))
(
etypecase
name
((
or
null
pathname
)
(
return
name
))
(
symbol
...
...
@@ -606,10 +614,10 @@ to throw an error if the pathname is absolute"
(
string
))
(
multiple-value-bind
(
relative
path
filename
file-only
)
(
split-unix-namestring-directory-components
name
:dot-dot
dot-dot
:ensure-directory
ensure-
directory
)
name
:dot-dot
dot-dot
:ensure-directory
(
eq
type
:
directory
)
)
(
multiple-value-bind
(
name
type
)
(
cond
((
or
ensure-
directory
(
null
filename
))
((
or
(
eq
type
:
directory
)
(
null
filename
))
(
values
nil
nil
))
(
type
(
values
filename
type
))
...
...
@@ -680,6 +688,14 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
(
and
pathname
(
subpathname
(
ensure-directory-pathname
pathname
)
subpath
:type
type
)))
(
defun*
subpathp
(
maybe-subpath
base-pathname
)
(
and
(
pathnamep
maybe-subpath
)
(
pathnamep
base-pathname
)
(
absolute-pathname-p
maybe-subpath
)
(
absolute-pathname-p
base-pathname
)
(
directory-pathname-p
base-pathname
)
(
not
(
wild-pathname-p
base-pathname
))
(
with-pathname-defaults
()
(
let
((
enough
(
enough-namestring
maybe-subpath
base-pathname
)))
(
and
(
relative-pathname-p
enough
)
(
pathname
enough
))))))
;;; Pathname host and its root
(
defun*
pathname-root
(
pathname
)
(
make-pathname*
:directory
'
(
:absolute
)
...
...
@@ -795,16 +811,16 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
;;; absolute vs relative
(
defun*
ensure-pathname-absolute
(
path
)
(
defun*
ensure-pathname-absolute
(
path
&optional
defaults
)
(
cond
((
absolute-pathname-p
path
)
path
)
((
stringp
path
)
(
ensure-pathname-absolute
(
pathname
path
)))
((
stringp
path
)
(
ensure-pathname-absolute
(
pathname
path
)
defaults
))
((
not
(
pathnamep
path
))
(
error
"not a valid pathname designator ~S"
path
))
(
t
(
let
((
resolved
(
resolve-symlinks
path
)
))
(
assert
(
absolute
-
pathname
-p
resolved
))
resolved
))))
(
(
absolute-pathname-p
defaults
)
(
merge-pathnames*
path
defaults
))
(
t
(
error
"Cannot ensure ~S is evaluated as an
absolute
pathname
with defaults ~S"
path
defaults
))))
(
defun
*
relativize-directory-component
(
directory-component
)
(
defun
relativize-directory-component
(
directory-component
)
(
let
((
directory
(
normalize-pathname-directory-component
directory-component
)))
(
cond
((
stringp
directory
)
...
...
@@ -998,7 +1014,7 @@ Otherwise, this will be the root of some implementation-dependent filesystem hos
want-non-wild
want-wild
wilden
want-file
want-directory
ensure-directory
want-existing
ensure-directories-exist
ensure-
truename
truenamize
truename
resolve-symlinks
truenamize
&aux
(
p
pathname
))
;; mutable working copy, preserve original
"Coerces its argument into a PATHNAME,
optionally doing some transformations and checking specified constraints.
...
...
@@ -1047,7 +1063,8 @@ WANT-WILD checks that pathname is a wild pathname
WILDEN merges the pathname with **/*.*.* if it is not wild
WANT-EXISTING checks that a file (or directory) exists with that pathname.
ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
ENSURE-TRUENAME replaces the pathname by its truename, or errors if not possible.
TRUENAME replaces the pathname by its truename, or errors if not possible.
RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
(
block
nil
(
flet
((
report-error
(
keyword
description
&rest
arguments
)
...
...
@@ -1082,8 +1099,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
"Could not make into an absolute pathname even after merging with ~S"
defaults
)
(
check
ensure-subpath
(
absolute-pathname-p
defaults
)
"cannot be checked to be a subpath of non-absolute pathname ~S"
defaults
)
(
check
ensure-subpath
(
not
(
absolute-pathname-p
(
enough-namestring
p
defaults
)))
"is not a sub pathname of ~S"
defaults
)
(
check
ensure-subpath
(
subpathp
p
defaults
)
"is not a sub pathname of ~S"
defaults
)
(
check
want-file
(
file-pathname-p
p
)
"Expected a file pathname"
)
(
check
want-directory
(
directory-pathname-p
p
)
"Expected a directory pathname"
)
(
transform
ensure-directory
(
not
(
directory-pathname-p
p
))
(
ensure-directory-pathname
p
))
...
...
@@ -1091,17 +1107,18 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
(
check
want-wild
(
wild-pathname-p
p
)
"Expected a wildcard pathname"
)
(
transform
wilden
(
not
(
wild-pathname-p
p
))
(
wilden
p
))
(
when
want-existing
(
let
((
existing
(
probe-file*
p
)))
(
let
((
existing
(
probe-file*
p
:truename
truename
)))
(
if
existing
(
when
(
or
ensure-truename
truenamize
)
(
when
truename
(
return
existing
))
(
err
want-existing
"Expected an existing pathname"
))))
(
when
ensure-directories-exist
(
ensure-directories-exist
p
))
(
when
ensure-
truename
(
when
truename
(
let
((
truename
(
truename*
p
)))
(
if
truename
(
return
truename
)
(
err
truename
"Can't get a truename for pathname"
))))
(
transform
resolve-symlinks
()
(
resolve-symlinks
p
))
(
transform
truenamize
()
(
truenamize
p
))
p
))))
...
...
source-registry.lisp
View file @
072692f1
...
...
@@ -153,7 +153,7 @@ system names to pathnames of .asd files")
(
defun*
wrapping-source-registry
()
`
(
:source-registry
#+
(
or
ecl
sbcl
)
(
:tree
,
(
lisp-implementation-directory
:truename
t
))
#+
(
or
ecl
sbcl
)
(
:tree
,
(
resolve-symlinks*
(
lisp-implementation-directory
)
))
#+
mkcl
(
:tree
,
(
translate-logical-pathname
"CONTRIB:"
))
:inherit-configuration
#+
cmu
(
:tree
#p"modules:"
)
...
...
@@ -221,10 +221,10 @@ system names to pathnames of .asd files")
(
defmethod
process-source-registry
((
pathname
#-
gcl<2.7
pathname
#+
gcl<2.7
t
)
&key
inherit
register
)
(
cond
((
directory-pathname-p
pathname
)
(
let
((
*here-directory*
(
truenamize
pathname
)))
(
let
((
*here-directory*
(
resolve-symlinks*
pathname
)))
(
process-source-registry
(
validate-source-registry-directory
pathname
)
:inherit
inherit
:register
register
)))
((
probe-file*
pathname
)
((
probe-file*
pathname
:truename
*resolve-symlinks*
)
(
let
((
*here-directory*
(
pathname-directory-pathname
pathname
)))
(
process-source-registry
(
validate-source-registry-file
pathname
)
:inherit
inherit
:register
register
)))
...
...
system.lisp
View file @
072692f1
...
...
@@ -71,7 +71,9 @@ in which the system specification (.asd file) is located."
(
defmethod
builtin-system-p
((
s
system
))
(
let*
((
system
(
find-system
s
nil
))
(
sysdir
(
and
system
(
component-pathname
system
)))
(
truesysdir
(
and
sysdir
(
truename*
sysdir
)))
(
impdir
(
lisp-implementation-directory
:truename
t
)))
(
and
truesysdir
impdir
(
pathname-match-p
truesysdir
(
wilden
impdir
))
t
)))
(
truesysdir
(
truename*
sysdir
))
(
impdir
(
lisp-implementation-directory
))
(
trueimpdir
(
truename*
impdir
)))
(
and
sysdir
impdir
(
or
(
subpathp
sysdir
impdir
)
(
subpathp
truesysdir
trueimpdir
)))))
test/test-bundle.script
View file @
072692f1
...
...
@@ -22,12 +22,12 @@
(bundle-1 (asdf:output-file op (find-system :test-bundle-1)))
(bundle-2 (asdf:output-file op (find-system :test-bundle-2))))
(DBG :test-bundle bundle-1 bundle-2)
(
asdf::
delete-file-if-exists bundle-1)
(
asdf::
delete-file-if-exists bundle-2)
(
asdf:
operate '
asdf:
load-fasl-op :test-bundle-2)
(delete-file-if-exists bundle-1)
(delete-file-if-exists bundle-2)
(operate 'load-fasl-op :test-bundle-2)
;; Check that the bundles were indeed created.
(assert (probe-file bundle-1))
(assert (probe-file bundle-2))
;; Check that the files were indeed loaded.
(assert (symbol-value (
asdf::
find-symbol* :*file1* :test-package)))
(assert (symbol-value (
asdf::
find-symbol* :*file3* :test-package)))))
(assert (symbol-value (find-symbol* :*file1* :test-package)))
(assert (symbol-value (find-symbol* :*file3* :test-package)))))
test/test-force.script
View file @
072692f1
...
...
@@ -3,7 +3,6 @@
(load-asdf)
(with-test ()
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'test-force)
(let* ((file1 (asdf:compile-file-pathname* "file1"))
...
...
test/test-missing-lisp-file.script
View file @
072692f1
...
...
@@ -18,12 +18,12 @@
(make-pathname :name "fileMissing"
:type "lisp"
:defaults
*
default-pathname-defaults
*)))
*
test-directory
*)))
(template-file (namestring
(make-pathname :name "file1"
:type "lisp"
:defaults
*
default-pathname-defaults
*))))
*
test-directory
*))))
(asdf::concatenate-files (list template-file) missing-name)
(unless (probe-file missing-name)
(format t "File copy failed.~%"))
...
...
test/test-module-depend.script
View file @
072692f1
...
...
@@ -3,7 +3,6 @@
(load-asdf)
(with-test ()
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-module-depend)
;; test that it compiled
...
...
test/test-nested-components.script
View file @
072692f1
...
...
@@ -7,7 +7,7 @@
(with-test ()
(setf asdf:*central-registry* nil)
(load
(merge-pathnames
"test-nested-components-1.asd")
)
(load "test-nested-components-1.asd")
(print
(list