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
Didier Verna
asdf
Commits
fb3d1204
Commit
fb3d1204
authored
Jan 18, 2013
by
Francois-Rene Rideau
Browse files
2.26.120: vanquishing the dragon of CL pathnames so you don't have to.
(equal #p"ccl:" #p"/") ==> T. Yikes.
parent
072692f1
Changes
11
Hide whitespace changes
Inline
Side-by-side
asdf.asd
View file @
fb3d1204
...
...
@@ -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.1
19
"
;; to be automatically updated by bin/bump-revision
:version
"2.26.1
20
"
;; 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
))))
...
...
bundle.lisp
View file @
fb3d1204
...
...
@@ -16,7 +16,7 @@
#:operation-monolithic-p
#:user-system-p
#:user-system
#:trivial-system-p
#:gather-actions
#:operated-components
#+
ecl
#:make-build
#+
mkcl
#:bundle-system
#+
ecl
#:make-build
#:register-pre-built-system
#:build-args
#:name-suffix
#:prologue-code
#:epilogue-code
#:static-library
#:component-translate-output-p
#:translate-output-p
...
...
defsystem.lisp
View file @
fb3d1204
...
...
@@ -32,16 +32,9 @@
;; 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
(
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
))))))
(
absolutize-pathnames
(
list
pathname
(
load-pathname
)
*default-pathname-defaults*
(
getcwd
))
:resolve-symlinks
*resolve-symlinks*
))
;;; Component class
...
...
find-system.lisp
View file @
fb3d1204
...
...
@@ -155,7 +155,12 @@ Going forward, we recommend new users should be using the source-registry.
(
defun*
probe-asd
(
name
defaults
&key
truename
)
(
block
nil
(
when
(
directory-pathname-p
defaults
)
(
let*
((
file
(
probe-file*
(
subpathname
defaults
name
:type
"asd"
)
:truename
truename
)))
(
let*
((
file
(
probe-file*
(
absolutize-pathnames
(
list
(
make-pathname
:name
name
:type
"asd"
)
defaults
*default-pathname-defaults*
(
getcwd
))
:resolve-symlinks
truename
)
:truename
truename
)))
(
when
file
(
return
file
)))
#-
(
or
clisp
genera
)
; clisp doesn't need it, plain genera doesn't have read-sequence(!)
...
...
@@ -177,11 +182,10 @@ Going forward, we recommend new users should be using the source-registry.
(
block
nil
(
unwind-protect
(
dolist
(
dir
*central-registry*
)
(
let
((
defaults
(
resolve-symlinks*
(
eval
dir
))
)
directorized
truenamized
)
(
let
((
defaults
(
eval
dir
))
directorized
)
(
when
defaults
(
cond
((
and
(
directory-pathname-p
defaults
)
(
absolute-pathname-p
defaults
))
(
cond
((
directory-pathname-p
defaults
)
(
let*
((
file
(
probe-asd
name
defaults
:truename
*resolve-symlinks*
)))
(
when
file
(
return
file
))))
...
...
@@ -196,13 +200,6 @@ Going forward, we recommend new users should be using the source-registry.
(
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
))
...
...
@@ -305,14 +302,18 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(
multiple-value-bind
(
foundp
found-system
pathname
previous
previous-time
)
(
locate-system
name
)
(
assert
(
eq
foundp
(
and
(
or
found-system
pathname
previous
)
t
)))
(
when
(
and
found-system
(
not
previous
))
(
register-system
found-system
))
(
when
(
and
pathname
(
not
(
and
previous
(
pathname-equal
pathname
(
system-source-file
previous
))
(
stamp<=
(
safe-file-write-date
pathname
)
previous-time
))))
;; only load when it's a pathname that is different or has newer content
(
load-sysdef
name
pathname
))
(
let
((
previous-pathname
(
and
previous
(
system-source-file
previous
)))
(
system
(
or
previous
found-system
)))
(
when
(
and
found-system
(
not
previous
))
(
register-system
found-system
))
(
when
(
and
system
pathname
)
(
setf
(
system-source-file
system
)
pathname
))
(
when
(
and
pathname
(
not
(
and
previous
(
pathname-equal
pathname
previous-pathname
)
(
stamp<=
(
safe-file-write-date
pathname
)
previous-time
))))
;; only load when it's a pathname that is different or has newer content
(
load-sysdef
name
pathname
)))
(
let
((
in-memory
(
system-registered-p
name
)))
; try again after loading from disk if needed
(
return
(
cond
...
...
header.lisp
View file @
fb3d1204
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.1
19
: Another System Definition Facility.
;;; This is ASDF 2.26.1
20
: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
...
...
pathname.lisp
View file @
fb3d1204
...
...
@@ -54,6 +54,7 @@
#:parse-file-location-info
#:parse-windows-shortcut
;; Checking constraints
#:ensure-pathname
#:absolutize-pathnames
;; Output translations
#:*output-translation-function*
))
...
...
@@ -165,21 +166,21 @@ and make a new pathname with corresponding components and specified logical HOST
(
when
(
stringp
p1
)
(
setf
p1
(
pathname
p1
)))
(
when
(
stringp
p2
)
(
setf
p2
(
pathname
p2
)))
(
flet
((
normalize-component
(
x
)
(
and
(
not
(
member
x
'
(
nil
:unspecific
:newest
(
:relative
))
:test
'equal
))
x
)))
(
unless
(
member
x
'
(
nil
:unspecific
:newest
(
:relative
))
:test
'equal
)
x
)))
(
macrolet
((
=?
(
&rest
accessors
)
(
flet
((
frob
(
x
)
(
reduce
'list
(
cons
'normalize-component
accessors
)
:initial-value
x
:from-end
t
)))
`
(
equal
,
(
frob
'p1
)
,
(
frob
'p2
)))))
(
or
(
and
(
null
p1
)
(
null
2
))
(
or
(
and
(
null
p1
)
(
null
p
2
))
(
and
(
pathnamep
p1
)
(
pathnamep
p2
)
(
or
(
equal
p1
p2
)
(
=?
pathname-host
)
(
=?
pathname-device
)
(
=?
normalize-pathname-directory-component
pathname-directory
)
(
=?
pathname-name
)
(
=?
pathname-type
)
(
=?
pathname-version
)))))))
(
and
(
=?
pathname-host
)
(
=?
pathname-device
)
(
=?
normalize-pathname-directory-component
pathname-directory
)
(
=?
pathname-name
)
(
=?
pathname-type
)
(
=?
pathname-version
)))))))
(
defun*
logical-pathname-p
(
x
)
(
typep
x
'logical-pathname
))
...
...
@@ -401,7 +402,7 @@ or the original (parsed) pathname if it is false (the default)."
;; and we can survive and we will continue the planning
;; as if the file were very old.
;; (or should we treat the case in a different, special way?)
(
and
pathname
(
probe-file*
pathname
)
(
ignore-errors
(
file-write-date
pathname
))))
(
and
(
probe-file*
pathname
)
(
ignore-errors
(
file-write-date
pathname
))))
(
defun*
directory*
(
pathname-spec
&rest
keys
&key
&allow-other-keys
)
(
apply
'directory
pathname-spec
...
...
@@ -413,7 +414,7 @@ or the original (parsed) pathname if it is false (the default)."
'
(
:resolve-symlinks
nil
))))))
(
defun*
filter-logical-directory-results
(
directory
entries
merger
)
(
if
(
typep
directory
'
logical-pathname
)
(
if
(
logical-pathname
-p
directory
)
;; Try hard to not resolve logical-pathname into physical pathnames;
;; otherwise logical-pathname users/lovers will be disappointed.
;; If directory* could use some implementation-dependent magic,
...
...
@@ -421,7 +422,7 @@ or the original (parsed) pathname if it is false (the default)."
;; we only keep pathnames for which specifying the name and
;; translating the LPN commute.
(
loop
:for
f
:in
entries
:for
p
=
(
or
(
and
(
typep
f
'
logical-pathname
)
f
)
:for
p
=
(
or
(
and
(
logical-pathname
-p
f
)
f
)
(
let*
((
u
(
ignore-errors
(
funcall
merger
f
))))
;; The first u avoids a cumbersome (truename u) error.
;; At this point f should already be a truename,
...
...
@@ -432,7 +433,7 @@ or the original (parsed) pathname if it is false (the default)."
(
defun*
directory-files
(
directory
&optional
(
pattern
*wild-file*
))
(
let
((
dir
(
pathname
directory
)))
(
when
(
typep
dir
'
logical-pathname
)
(
when
(
logical-pathname
-p
dir
)
;; Because of the filtering we do below,
;; logical pathnames have restrictions on wild patterns.
;; Not that the results are very portable when you use these patterns on physical pathnames.
...
...
@@ -688,14 +689,6 @@ 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
)
...
...
@@ -758,6 +751,15 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
:defaults
pathname
)))
pathname
)))
(
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
))
(
pathname-equal
(
pathname-root
maybe-subpath
)
(
pathname-root
base-pathname
))
(
with-pathname-defaults
()
(
let
((
enough
(
enough-namestring
maybe-subpath
base-pathname
)))
(
and
(
relative-pathname-p
enough
)
(
pathname
enough
))))))
;;; Resolving symlinks somewhat
(
defun*
truenamize
(
pathname
&optional
(
defaults
*default-pathname-defaults*
))
...
...
@@ -765,15 +767,15 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
(
block
nil
(
when
(
typep
pathname
'
(
or
null
logical-pathname
))
(
return
pathname
))
(
let
((
p
(
merge-pathnames*
pathname
defaults
)))
(
when
(
typep
p
'
logical-pathname
)
(
return
p
))
(
let
((
found
(
probe-file*
p
)))
(
when
(
logical-pathname
-p
p
)
(
return
p
))
(
let
((
found
(
probe-file*
p
:truename
t
)))
(
when
found
(
return
found
)))
(
unless
(
absolute-pathname-p
p
)
(
let
((
true-defaults
(
truename*
defaults
)))
(
when
true-defaults
(
setf
p
(
merge-pathnames
pathname
true-defaults
)))))
(
unless
(
absolute-pathname-p
p
)
(
return
p
))
(
let
((
sofar
(
probe-file*
(
pathname-root
p
))))
(
let
((
sofar
(
probe-file*
(
pathname-root
p
)
:truename
t
)))
(
unless
sofar
(
return
p
))
(
flet
((
solution
(
directories
)
(
merge-pathnames*
...
...
@@ -790,7 +792,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
:for
more
=
(
probe-file*
(
merge-pathnames*
(
make-pathname*
:directory
`
(
:relative
,
dir
))
sofar
))
:do
sofar
)
:truename
t
)
:do
(
if
more
(
setf
sofar
more
)
(
return
(
solution
rest
)))
...
...
@@ -811,14 +813,18 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
;;; absolute vs relative
(
defun*
ensure-pathname-absolute
(
path
&optional
defaults
)
(
defun*
ensure-pathname-absolute
(
path
&optional
defaults
(
on-error
'error
)
)
(
cond
((
absolute-pathname-p
path
)
path
)
((
absolute-pathname-p
path
))
((
stringp
path
)
(
ensure-pathname-absolute
(
pathname
path
)
defaults
))
((
not
(
pathnamep
path
))
(
error
"not a valid pathname designator ~S"
path
))
((
absolute-pathname-p
defaults
)
(
merge-pathnames*
path
defaults
))
(
t
(
error
"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
path
defaults
))))
((
not
(
pathnamep
path
))
(
call-function
on-error
"not a valid pathname designator ~S"
path
))
((
absolute-pathname-p
defaults
)
(
or
(
absolute-pathname-p
(
merge-pathnames*
path
defaults
))
(
call-function
on-error
"Failed to merge ~S with ~S into an absolute pathname"
path
defaults
)))
(
t
(
call-function
on-error
"Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
path
defaults
))))
(
defun
relativize-directory-component
(
directory-component
)
(
let
((
directory
(
normalize-pathname-directory-component
directory-component
)))
...
...
@@ -850,7 +856,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
#+
clozure
:if-exists
#+
clozure
:rename-and-delete
))
(
defun*
delete-file-if-exists
(
x
)
(
when
(
and
x
(
probe-file*
x
)
)
(
when
(
probe-file*
x
)
(
delete-file
x
)))
;;; Translate a pathname
...
...
@@ -891,8 +897,7 @@ For the latter case, we ought pick random suffix and atomically open it."
(
multiple-value-prog1
(
funcall
fun
staging
)
(
rename-file-overwriting-target
staging
pathname
))
(
when
(
probe-file*
staging
)
(
delete-file
staging
)))))
(
delete-file-if-exists
staging
))))
(
defmacro
with-staging-pathname
((
pathname-var
&optional
(
pathname-value
pathname-var
))
&body
body
)
`
(
call-with-staging-pathname
,
pathname-value
#'
(
lambda
(
,
pathname-var
)
,@
body
)))
...
...
@@ -910,7 +915,7 @@ For the latter case, we ought pick random suffix and atomically open it."
((
:host
)
(
pathname-host-pathname
x
))
((
nil
)
(
nil-pathname
x
))))
(
when
want-existing
;; CCL's probe-file will choke if d-p-d is logical
(
setf
x
(
and
(
probe-file*
x
)
x
)))
(
setf
x
(
probe-file*
x
)))
(
and
(
physical-pathname-p
x
)
x
))))
(
or
(
sanitize
defaults
)
(
when
fallback
...
...
@@ -1123,5 +1128,30 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
p
))))
(
defun
absolutize-pathnames
(
pathnames
&key
type
(
resolve-symlinks
*resolve-symlinks*
)
truename
)
"Given a list of PATHNAMES where each is in the context of the next ones,
try to resolve these pathnames into an absolute pathname; first gently, then harder."
(
block
nil
(
labels
((
resolve
(
x
)
(
or
(
when
truename
(
absolute-pathname-p
(
truename*
x
)))
(
when
resolve-symlinks
(
absolute-pathname-p
(
resolve-symlinks
x
)))
(
absolute-pathname-p
x
)
(
unless
resolve-symlinks
(
absolute-pathname-p
(
resolve-symlinks
x
)))
(
unless
truename
(
absolute-pathname-p
(
truename*
x
)))
(
return
nil
)))
(
tryone
(
x
type
rest
)
(
resolve
(
or
(
absolute-pathname-p
x
)
(
subpathname
(
recurse
rest
:directory
)
x
:type
type
))))
(
recurse
(
pathnames
type
)
(
if
(
null
pathnames
)
(
return
nil
)
(
tryone
(
first
pathnames
)
type
(
rest
pathnames
)))))
(
recurse
pathnames
type
))))
;;; Hook for output translations
(
defvar
*output-translation-function*
'identity
)
system.lisp
View file @
fb3d1204
...
...
@@ -65,7 +65,6 @@ in which the system specification (.asd file) is located."
(
defun*
system-relative-pathname
(
system
name
&key
type
)
(
subpathname
(
system-source-directory
system
)
name
:type
type
))
;;;; Beware of builtin systems
(
defgeneric*
builtin-system-p
(
system
))
(
defmethod
builtin-system-p
((
s
system
))
...
...
test/script-support.lisp
View file @
fb3d1204
...
...
@@ -36,6 +36,7 @@ Some constraints:
`
(
;; If you want to trace some stuff while debugging ASDF,
;; here's a nice place to say what.
;; These string designators will be interned in ASDF after it is loaded.
:absolutize-pathnames
))
(
defvar
*debug-asdf*
nil
)
...
...
test/test-bundle.script
View file @
fb3d1204
...
...
@@ -22,12 +22,14 @@
(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)
(assert-equal (list bundle-2)
(input-files (make-operation 'load-fasl-op) (find-system :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))
(assert (probe-file bundle-1))
;; Check that the files were indeed loaded.
(assert (symbol-value (find-symbol* :*file1* :test-package)))
(assert (symbol-value (find-symbol* :*file3* :test-package)))))
upgrade.lisp
View file @
fb3d1204
...
...
@@ -45,7 +45,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(
asdf-version
"2.26.1
19
"
)
(
asdf-version
"2.26.1
20
"
)
(
existing-asdf
(
find-class
(
find-symbol*
:component
:asdf
nil
)
nil
))
(
existing-version
*asdf-version*
)
(
already-there
(
equal
asdf-version
existing-version
)))
...
...
version.lisp-expr
View file @
fb3d1204
"2.26.1
19
"
"2.26.1
20
"
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