Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
A
asdf
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Container Registry
Model registry
Operate
Environments
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Jan Moringen
asdf
Commits
e8a3285f
Commit
e8a3285f
authored
15 years ago
by
Francois-Rene Rideau
Browse files
Options
Downloads
Patches
Plain Diff
Fix more of the bugs. Scanning of subdiretories very slow on SBCL.
parent
79502b1c
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
asdf.lisp
+110
-158
110 additions, 158 deletions
asdf.lisp
with
110 additions
and
158 deletions
asdf.lisp
+
110
−
158
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.
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
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!
Save comment
Cancel
Please
register
or
sign in
to comment