Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
asdf
asdf
Commits
e8a3285f
Commit
e8a3285f
authored
Jan 15, 2010
by
Francois-Rene Rideau
Browse files
Fix more of the bugs. Scanning of subdiretories very slow on SBCL.
parent
79502b1c
Changes
1
Hide whitespace changes
Inline
Side-by-side
asdf.lisp
View file @
e8a3285f
...
...
@@ -139,6 +139,7 @@
#:*enable-asdf-binary-locations*
#:implementation-specific-directory-name
)
(
:intern
#:coerce-name
#:getenv
#:system-registered-p
#:asdf-message
#:resolve-symlinks
...
...
@@ -149,6 +150,7 @@
(
:use
#:common-lisp
#:asdf
)
(
:import-from
#:asdf
#:coerce-name
#:getenv
#:system-registered-p
#:asdf-message
#:resolve-symlinks
...
...
@@ -406,6 +408,25 @@ and NIL NAME and TYPE components"
#-
allegro
(
truename
path
)
#+
allegro
(
excl:pathname-resolve-symbolic-links
path
))
(
defun
getenv
(
x
)
#+
sbcl
(
sb-ext:posix-getenv
x
)
#+
clozure
(
ccl::getenv
x
)
#+
clisp
(
ext:getenv
x
)
#+
cmu
(
cdr
(
assoc
(
intern
x
:keyword
)
ext:*environment-list*
))
#+
lispworks
(
lispworks:environment-xiable
x
)
#+
allegro
(
sys:getenv
x
)
#+
gcl
(
system:getenv
x
)
#+
ecl
(
si:getenv
x
))
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
...
...
@@ -629,8 +650,7 @@ called with an object of type asdf:system."
;;; convention that functions in this list are prefixed SYSDEF-
(
defvar
*system-definition-search-functions*
'
(
sysdef-central-registry-search
sysdef-source-registry-search
))
'
(
sysdef-central-registry-search
))
(
defun
system-definition-pathname
(
system
)
(
let
((
system-name
(
coerce-name
system
)))
...
...
@@ -732,60 +752,6 @@ to `~a` which is not a directory.~@:>"
(
list
new
)
(
subseq
*central-registry*
(
1+
position
))))))))))
(
defun
sysdef-source-registry-search
(
system
)
(
let
((
name
(
coerce-name
system
))
(
to-remove
nil
)
(
to-replace
nil
))
(
block
nil
(
unwind-protect
(
dolist
(
dir
(
source-registry
))
(
let
((
defaults
(
eval
dir
)))
(
when
defaults
(
cond
((
directory-pathname-p
defaults
)
(
let
((
file
(
and
defaults
(
make-pathname
:defaults
defaults
:version
:newest
:name
name
:type
"asd"
:case
:local
)))
#+
(
and
(
or
win32
windows
)
(
not
:clisp
))
(
shortcut
(
make-pathname
:defaults
defaults
:version
:newest
:name
name
:type
"asd.lnk"
:case
:local
)))
(
if
(
and
file
(
probe-file
file
))
(
return
file
))
#+
(
and
(
or
win32
windows
)
(
not
:clisp
))
(
when
(
probe-file
shortcut
)
(
let
((
target
(
parse-windows-shortcut
shortcut
)))
(
when
target
(
return
(
pathname
target
)))))))
(
t
(
restart-case
(
let*
((
*print-circle*
nil
)
(
message
(
format
nil
"~@<While searching for system `~a`: `~a` evaluated ~
to `~a` which is not a directory.~@:>"
system
dir
defaults
)))
(
error
message
))
(
remove-entry-from-registry
()
:report
"Remove entry from (source-registry) and continue"
(
push
dir
to-remove
))
(
coerce-entry-to-directory
()
:report
(
lambda
(
s
)
(
format
s
"Coerce entry to ~a, replace ~a and continue."
(
ensure-directory-pathname
defaults
)
dir
))
(
push
(
cons
dir
(
ensure-directory-pathname
defaults
))
to-replace
))))))))
;; cleanup
(
dolist
(
dir
to-remove
)
(
setf
(
central-registry
)
(
remove
dir
(
source-registry
))))
(
dolist
(
pair
to-replace
)
(
let*
((
current
(
car
pair
))
(
new
(
cdr
pair
))
(
position
(
position
current
(
source-registry
))))
(
setf
(
source-registry
)
(
append
(
subseq
(
source-registry
)
0
position
)
(
list
new
)
(
subseq
(
source-registry
)
(
1+
position
))))))))))
(
defun
make-temporary-package
()
(
flet
((
try
(
counter
)
(
ignore-errors
...
...
@@ -2097,23 +2063,7 @@ applied by the plain `*source-to-target-mappings*`."
;;;; for invalidating registry entries, etc.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
(
defun
get-env-var
(
x
)
#+
sbcl
(
sb-ext:posix-getenv
x
)
#+
clozure
(
ccl::getenv
x
)
#+
clisp
(
ext:getenv
x
)
#+
cmu
(
cdr
(
assoc
(
intern
x
:keyword
)
ext:*environment-list*
))
#+
lispworks
(
lispworks:environment-xiable
x
)
#+
allegro
(
sys:getenv
x
)
#+
gcl
(
system:getenv
x
)
#+
ecl
(
si:getenv
x
))
(
pushnew
'sysdef-source-registry-search
*system-definition-search-functions*
)
;; Using ack 1.2 exclusions
(
defvar
*default-exclusions*
...
...
@@ -2122,37 +2072,53 @@ applied by the plain `*source-to-target-mappings*`."
"_sgbak"
"autom4te.cache"
"cover_db"
"_build"
))
(
defun
default-registry
()
(
let
((
paths
#+
(
and
asdf
sbcl
)
(
list
(
let
((
home
(
sb-ext:posix-getenv
"SBCL_HOME"
)))
(
when
(
and
home
(
not
(
string=
home
""
)))
(
merge-pathnames
"site-systems/"
(
truename
home
))))
(
merge-pathnames
".sbcl/systems/"
(
user-homedir-pathname
)))
#+
(
and
asdf
clisp
)
(
list
(
merge-pathnames
".clc/systems/"
(
user-homedir-pathname
))
*default-pathname-defaults*
#P"/usr/share/common-lisp/systems/"
)
;; asdf:*central-registry*
#+
xcvb
xcvb:*search-path*
))
(
mapcar
#'
namestring
paths
)))
(
defvar
*source-registry*
'
())
;; (defvar *source-registry* (default-registry))
())
(
defvar
*source-registry*
())
(
defun
source-registry
()
*source-registry*
)
(
car
*source-registry*
)
)
(
defun
(
setf
source-registry
)
(
x
)
(
setf
*source-registry*
x
))
(
setf
*source-registry*
(
list
x
)
))
(
defun
source-registry-initialized-p
()
(
not
(
null
(
source-registry
))))
(
and
*source-registry*
t
))
(
defun
clear-source-registry
()
"Undoes any initialization of the source registry.
You might want to call that before you dump an image that would be resumed
with a different configuration, so the configuration would be re-read then."
;; TODO: in the future, have a hook that clients will use to clear any cache
;; that depends on this configuration.
(
setf
*source-registry*
'
())
(
values
))
;; from xcvb:search-path.lisp
(
defun
sysdef-source-registry-search
(
system
)
(
ensure-source-registry
)
(
let
((
name
(
coerce-name
system
)))
(
block
nil
(
dolist
(
dir
(
source-registry
))
(
let
((
defaults
(
eval
dir
)))
(
when
defaults
(
cond
((
directory-pathname-p
defaults
)
(
let
((
file
(
and
defaults
(
make-pathname
:defaults
defaults
:version
:newest
:name
name
:type
"asd"
:case
:local
)))
#+
(
and
(
or
win32
windows
)
(
not
:clisp
))
(
shortcut
(
make-pathname
:defaults
defaults
:version
:newest
:name
name
:type
"asd.lnk"
:case
:local
)))
(
when
(
and
file
(
probe-file
file
))
(
return
file
))
#+
(
and
(
or
win32
windows
)
(
not
:clisp
))
(
when
(
probe-file
shortcut
)
(
let
((
target
(
parse-windows-shortcut
shortcut
)))
(
when
target
(
return
(
pathname
target
))))))))))))))
;; from xcvb/search-path
(
defun
expand-search-path-string
(
string
&optional
(
previous-path
(
source-registry
)))
(
cond
((
or
(
null
string
)
(
equal
string
""
))
...
...
@@ -2192,23 +2158,6 @@ form."
:defaults
pathname
))
(
t
pathname
))))
(
defun
directory-exists-p
(
pathspec
)
"Checks whether the file named by the pathname designator PATHSPEC
exists and if it is a directory. Returns its truename if this is the
case, NIL otherwise. The truename is returned in directory form as if
by PATHNAME-AS-DIRECTORY."
#+
:allegro
(
and
(
excl:probe-directory
pathspec
)
(
pathname-as-directory
(
truename
pathspec
)))
#+
:lispworks
(
and
(
lw:file-directory-p
pathspec
)
(
pathname-as-directory
(
truename
pathspec
)))
#-
(
or
:allegro
:lispworks
)
(
let
((
result
(
file-exists-p
pathspec
)))
(
and
result
(
directory-pathname-p
result
)
result
)))
(
defun
file-exists-p
(
pathname
)
#+
(
or
sbcl
lispworks
openmcl
)
(
probe-file
pathname
)
...
...
@@ -2228,6 +2177,23 @@ by PATHNAME-AS-DIRECTORY."
#-
(
or
sbcl
cmu
lispworks
openmcl
allegro
clisp
)
(
error
"list-directory not implemented"
))
(
defun
directory-exists-p
(
pathspec
)
"Checks whether the file named by the pathname designator PATHSPEC
exists and if it is a directory. Returns its truename if this is the
case, NIL otherwise. The truename is returned in directory form as if
by PATHNAME-AS-DIRECTORY."
#+
:allegro
(
and
(
excl:probe-directory
pathspec
)
(
pathname-as-directory
(
truename
pathspec
)))
#+
:lispworks
(
and
(
lw:file-directory-p
pathspec
)
(
pathname-as-directory
(
truename
pathspec
)))
#-
(
or
:allegro
:lispworks
)
(
let
((
result
(
file-exists-p
pathspec
)))
(
and
result
(
directory-pathname-p
result
)
result
)))
(
defun
every-string-p
(
x
)
(
every
#'
stringp
x
))
...
...
@@ -2235,13 +2201,13 @@ by PATHNAME-AS-DIRECTORY."
(
defmethod
extract-registry-paths
((
type
(
eql
'files
)))
(
let
((
base
"source-registry.conf"
)
(
dirs
(
list
(
pathname
"
/etc
/common-lisp/"
)
(
merge-
pathname
s
"
.config
/common-lisp/"
(
user-homedir-pathname
)
))))
(
dirs
(
list
(
merge-
pathname
s
"
.config
/common-lisp/"
(
user-homedir-pathname
)
)
(
pathname
"
/etc
/common-lisp/"
))))
(
loop
:for
dir
:in
dirs
:collect
(
merge-pathnames
base
dir
))))
(
merge-pathnames
base
dir
))))
(
defmethod
extract-registry-paths
((
type
(
eql
'environment
)))
(
let
((
source-path
(
get
-
env
-var
"CL_SOURCE_REGISTRY"
)))
(
let
((
source-path
(
getenv
"CL_SOURCE_REGISTRY"
)))
(
when
source-path
(
expand-search-path
source-path
))))
...
...
@@ -2266,7 +2232,7 @@ by PATHNAME-AS-DIRECTORY."
(
defun
recurse-directory
(
directory
&optional
(
exclusions
*default-exclusions*
)
undetect
)
(
declare
(
ignorable
exclusions
))
(
let*
((
f
(
directory
(
merge-pathnames
(
if
undetect
(
if
undetect
#P"**/*.*"
(
progn
#+
(
or
asdf
sbcl
)
#P"**/*.asd"
...
...
@@ -2331,7 +2297,6 @@ by PATHNAME-AS-DIRECTORY."
:do
(
validate-directive
dir
))))
(
t
(
error
"Error: Unhandled condition"
)))))
(
defun
acquire-paths
(
path
&optional
recurse
)
(
when
(
directory-exists-p
path
)
(
let
((
p
(
ensure-directory-trailing-slash
path
)))
...
...
@@ -2339,15 +2304,6 @@ by PATHNAME-AS-DIRECTORY."
(
recurse-directory
p
)
(
list
p
)))))
;; checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
;; the latter, initialize. ASDF will call this function at the start
;; of (asdf:find-system).
(
defun
ensure-source-registry
()
(
if
(
source-registry-initialized-p
)
(
source-registry
)
(
initialize-source-registry
)))
;; TODO: remove duplicates, but won't it be expensive to have duplicates
;; removed everytime a new item is to be added?
(
defun
add-path-to-source-registry
(
path
&optional
recurse
)
...
...
@@ -2385,22 +2341,6 @@ by PATHNAME-AS-DIRECTORY."
directive
)
(
t
(
error
"Error: Unhandled condition."
))))
(
defun
process-source-registry-path
(
path
)
(
validate-file
path
)
(
multiple-value-bind
(
registry
count
)
(
read-file
path
)
(
destructuring-bind
(((
top
&rest
rest
))
c
)
(
list
registry
count
)
(
declare
(
ignore
c
)
(
ignorable
top
))
(
loop
:for
reg
:in
rest
:nconc
(
process-source-registry
reg
)))))
(
defun
process-source-registry-paths
(
paths
)
(
loop
:for
path
:in
paths
:nconc
(
process-source-registry-path
path
)))
;; If X is a CONS, parse it as a SEXP in the configuration DSL, and
;; extend or override inheritted configuration. If X is a STRING,
;; first parse it into a SEXP with READ (Alternate proposal: parse
...
...
@@ -2433,6 +2373,23 @@ by PATHNAME-AS-DIRECTORY."
((
:ignore-inherited-configuration
)
nil
))))))
(
defun
process-source-registry-path
(
path
)
(
when
(
probe-file
path
)
(
validate-file
path
)
(
multiple-value-bind
(
registry
count
)
(
read-file
path
)
(
destructuring-bind
(((
top
&rest
rest
))
c
)
(
list
registry
count
)
(
declare
(
ignore
c
)
(
ignorable
top
))
(
loop
:for
reg
:in
rest
:nconc
(
process-source-registry
reg
))))))
(
defun
process-source-registry-paths
(
paths
)
(
loop
:for
path
:in
paths
:nconc
(
process-source-registry-path
path
)))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
(
defun
initialize-source-registry
()
...
...
@@ -2443,20 +2400,15 @@ by PATHNAME-AS-DIRECTORY."
(
when
registry
(
setf
(
source-registry
)
(
remove-duplicates
registry
:test
#'
equal
)))
(
source-registry
)))
;; Undoes any initialization. You might want to call that before you
;; dump an image that would be resumed with a different configuration,
;; and return an empty configuration. Also will have a hook that
;; allows clients will use to clear any cache that depends on this
;; configuration.
(
defun
clear-source-registry
()
(
setf
(
source-registry
)
'
())
;; Should this module care about these variables?
;; (setf asdf::*central-registry* nil)
;; (setf xcvb::*search-path* nil)
(
values
(
source-registry
)))
;; checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
;; the latter, initialize. ASDF will call this function at the start
;; of (asdf:find-system).
(
defun
ensure-source-registry
()
(
if
(
source-registry-initialized-p
)
(
source-registry
)
(
initialize-source-registry
)))
;;;; -------------------------------------------------------------------------
;;;; Cleanups after hot-upgrade.
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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