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
1693dc3b
Commit
1693dc3b
authored
Jan 14, 2010
by
Rommel M. Martinez
Browse files
Added support for user- and system- preference files
parent
45144c11
Changes
1
Hide whitespace changes
Inline
Side-by-side
asdf.lisp
View file @
1693dc3b
...
...
@@ -629,7 +629,8 @@ 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-central-registry-search
sysdef-source-registry-search
))
(
defun
system-definition-pathname
(
system
)
(
let
((
system-name
(
coerce-name
system
)))
...
...
@@ -731,6 +732,60 @@ 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
...
...
@@ -2042,6 +2097,382 @@ 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
))
;; Using ack 1.2 exclusions
(
defvar
*default-exclusions*
'
(
".bzr"
".cdv"
"~.dep"
"~.dot"
"~.nib"
"~.plst"
".git"
".hg"
".pc"
".svn"
"CVS"
"RCS"
"SCCS"
"_darcs"
"_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))
(
defun
source-registry
()
*source-registry*
)
(
defun
(
setf
source-registry
)
(
x
)
(
setf
*source-registry*
x
))
(
defun
source-registry-initialized-p
()
(
not
(
null
(
source-registry
))))
;; from xcvb:search-path.lisp
(
defun
expand-search-path-string
(
string
&optional
(
previous-path
(
source-registry
)))
(
cond
((
or
(
null
string
)
(
equal
string
""
))
previous-path
)
((
stringp
string
)
(
loop
:with
path
=
()
:with
start
=
0
:with
end
=
(
length
string
)
:for
i
=
(
or
(
position
#\:
string
:start
start
)
end
)
:do
(
let
((
s
(
subseq
string
start
i
)))
(
cond
((
equal
""
s
)
; empty element
nil
)
((
equal
"!"
s
)
; previous path
(
setf
path
(
append
(
reverse
previous-path
)
path
)))
(
t
(
push
s
path
))))
(
setf
start
(
1+
i
))
(
when
(
>=
start
end
)
(
return
(
nreverse
path
)))))))
(
defun
expand-search-path
(
path
)
(
mapcar
#'
pathname
(
expand-search-path-string
path
)))
;; from cl-fad:fad.lisp
(
defun
component-present-p
(
value
)
"Helper function for DIRECTORY-PATHNAME-P which checks whether VALUE
is neither NIL nor the keyword :UNSPECIFIC."
(
and
value
(
not
(
eql
value
:unspecific
))))
(
defun
directory-pathname-p
(
pathspec
)
"Returns NIL if PATHSPEC \(a pathname designator) does not designate
a directory, PATHSPEC otherwise. It is irrelevant whether file or
directory designated by PATHSPEC does actually exist."
(
and
(
not
(
component-present-p
(
pathname-name
pathspec
)))
(
not
(
component-present-p
(
pathname-type
pathspec
)))
pathspec
))
(
defun
pathname-as-directory
(
pathspec
)
"Converts the non-wild pathname designator PATHSPEC to directory
form."
(
let
((
pathname
(
pathname
pathspec
)))
(
when
(
wild-pathname-p
pathname
)
(
error
"Can't reliably convert wild pathnames."
))
(
cond
((
not
(
directory-pathname-p
pathspec
))
(
make-pathname
:directory
(
append
(
or
(
pathname-directory
pathname
)
(
list
:relative
))
(
list
(
file-namestring
pathname
)))
:name
nil
:type
nil
: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
)
#+
(
or
allegro
cmu
)
(
or
(
probe-file
(
pathname-as-directory
pathname
))
(
probe-file
pathname
))
#+
clisp
(
or
(
ignore-errors
(
probe-file
(
pathname-as-file
pathname
)))
(
ignore-errors
(
let
((
directory-form
(
pathname-as-directory
pathname
)))
(
when
(
ext:probe-directory
directory-form
)
directory-form
))))
#-
(
or
sbcl
cmu
lispworks
openmcl
allegro
clisp
)
(
error
"list-directory not implemented"
))
(
defun
every-string-p
(
x
)
(
every
#'
stringp
x
))
(
defgeneric
extract-registry-paths
(
type
)
(
:documentation
""
))
(
defmethod
extract-registry-paths
((
type
(
eql
'files
)))
(
let
((
base
"source-registry.conf"
)
(
dirs
(
list
(
pathname
"/etc/common-lisp/"
)
(
merge-pathnames
".config/common-lisp/"
(
user-homedir-pathname
)))))
(
loop
:for
dir
:in
dirs
:collect
(
merge-pathnames
base
dir
))))
(
defmethod
extract-registry-paths
((
type
(
eql
'environment
)))
(
let
((
source-path
(
get-env-var
"CL_SOURCE_REGISTRY"
)))
(
when
source-path
(
expand-search-path
source-path
))))
(
defmethod
extract-registry-paths
((
type
(
eql
'command-line
)))
nil
)
(
defun
directive-validator
(
directive
)
(
ecase
(
first
directive
)
((
:include
)
#'
file-exists-p
)
((
:directory
:tree
)
#'
directory-exists-p
)
((
:exclude
)
#'
every-string-p
)
((
:default-registry
:accept-inherited-configuration
:ignore-inherited-configuration
)
nil
)))
(
defun
ensure-directory-trailing-slash
(
directory
)
(
let
((
dir
(
if
(
stringp
directory
)
directory
(
namestring
directory
))))
(
if
(
char=
#\/
(
aref
dir
(
-
(
length
dir
)
1
)))
dir
(
concatenate
'string
dir
"/"
))))
(
defun
recurse-directory
(
directory
&optional
(
exclusions
*default-exclusions*
)
undetect
)
(
declare
(
ignorable
exclusions
))
(
let*
((
f
(
directory
(
merge-pathnames
(
if
undetect
#P"**/*.*"
(
progn
#+
(
or
asdf
sbcl
)
#P"**/*.asd"
#+
xcvb
#P"**/*.xcvb"
))
directory
)))
(
dirs
(
remove-duplicates
(
mapcar
#'
pathname-directory
f
)
:test
#'
equal
)))
(
loop
:for
dir
:in
dirs
:for
d
=
(
namestring
(
make-pathname
:directory
dir
))
:unless
(
loop
:for
exclusion
:in
exclusions
:when
(
search
exclusion
d
)
:return
t
)
:collect
d
)))
(
defun
read-file
(
file
)
(
with-open-file
(
in
file
)
(
loop
:with
eof
=
(
list
nil
)
:for
form
=
(
read
in
nil
eof
)
:and
form-count
:from
0
:until
(
eq
form
eof
)
:collect
form
:into
forms
:finally
(
return
(
values
forms
form-count
)))))
;; (define-condition malformed-init-file-error (error))
(
defun
validate-directive
(
directive
)
(
let
((
fn
(
directive-validator
directive
)))
(
destructuring-bind
(
type
&rest
rest
)
directive
(
if
(
and
(
keywordp
type
)
(
not
(
null
rest
)))
(
loop
:for
dir
:in
rest
:when
(
null
(
funcall
fn
dir
))
:do
(
error
"~A: Invalid value for directive ~S~%"
dir
(
first
directive
)))))))
(
defun
validate-file
(
file
)
(
multiple-value-bind
(
registry
count
)
(
read-file
file
)
(
cond
((
>
count
1
)
(
error
"~A:~%Exceeds maximum allowable expression: 1"
file
))
((
<
(
length
(
first
registry
))
2
)
(
error
"Error: Invalid top-level registry~%"
))
((
=
count
1
)
(
destructuring-bind
(((
top
&rest
rest
))
c
)
(
list
registry
count
)
(
declare
(
ignore
c
))
(
when
(
not
(
eql
top
:source-registry
))
(
error
"~A: ~A:~%Invalid top-level directive~%"
file
top
))
(
let
((
accept-present
(
find
:accept-inherited-configuration
rest
:key
#'
first
))
(
ignore-present
(
find
:ignore-inherited-configuration
rest
:key
#'
first
)))
(
when
(
and
accept-present
ignore-present
)
(
error
"~A:~%Both ~S and ~S~%cannot exist in the same file.~%"
file
:accept-inherited-configuration
:ignore-inherited-configuration
))
(
unless
(
or
accept-present
ignore-present
)
(
error
"~A:~%One of ~S or ~S~%directives not found.~%"
file
:accept-inherited-configuration
:ignore-inherited-configuration
)))
(
loop
:for
dir
:in
rest
: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
)))
(
if
recurse
(
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
)
(
let*
((
dirs
(
acquire-paths
path
recurse
))
;; (file (when (file-exists-p path) path))
;; (paths (or dirs file))
(
paths
dirs
))
(
when
paths
(
setf
(
source-registry
)
(
append
(
source-registry
)
paths
))
(
source-registry
))))
(
defun
add-paths-to-source-registry
(
paths
&optional
recurse
)
(
loop
:for
path
:in
paths
:collect
(
add-path-to-source-registry
path
recurse
)))
(
defun
collect-path
(
path
&optional
recurse
)
(
let*
((
dirs
(
acquire-paths
path
recurse
))
;; (file (when (file-exists-p path) path))
;; (p (or dir file)
(
paths
dirs
))
(
when
paths
paths
)))
(
defun
collect-paths
(
paths
&optional
recurse
)
(
loop
:for
path
:in
paths
:nconc
(
collect-path
path
recurse
)))
(
defun
read-directive
(
directive
)
(
cond
((
stringp
directive
)
(
read-from-string
directive
))
((
consp
directive
)
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
;; some shell-friendly text representation). The inheritted
;; configuration is provided in optional argument inherit, itself a
;; function that returns the previous configuration, with NIL
;; designating the default of #'ensure-source-registry. Internally,
;; initialize-source-registry-configuration can use this with a series
;; of functions for inheritted configuration.
(
defun
process-source-registry
(
directive
&optional
(
inherit
#'
source-registry
))
(
declare
(
ignorable
inherit
))
(
let
((
reg
(
funcall
inherit
))
(
dir
(
read-directive
directive
)))
(
declare
(
ignorable
reg
))
(
when
dir
(
destructuring-bind
(
type
&rest
rest
)
dir
(
ecase
type
((
:include
)
(
process-source-registry-paths
rest
))
((
:directory
)
(
collect-paths
rest
))
((
:tree
)
(
collect-paths
rest
t
))
((
:default-registry
)
(
default-registry
))
((
:accept-inherited-configuration
)
(
when
reg
(
collect-paths
reg
)))
((
:ignore-inherited-configuration
)
nil
))))))
;; Will read the configuration and initialize all internal variables,
;; and return the new configuration.
(
defun
initialize-source-registry
()
(
let*
((
sources
(
or
(
extract-registry-paths
'command-line
)
(
extract-registry-paths
'environment
)
(
extract-registry-paths
'files
)))
(
registry
(
process-source-registry-paths
sources
)))
(
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
)))
;;;; -------------------------------------------------------------------------
;;;; Cleanups after hot-upgrade.
;;;; Things to do in case we're upgrading from a previous version of ASDF.
...
...
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