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
d88e4273
Commit
d88e4273
authored
Aug 27, 2016
by
Francois-Rene Rideau
Browse files
Defensively physicalize pathnames
This make test-logical-pathname.script work on CLISP, despite CLISP bug 677.
parent
a763da75
Changes
4
Hide whitespace changes
Inline
Side-by-side
test/test-logical-pathname.script
View file @
d88e4273
;;; -*- Lisp -*-
(defun wild (&rest keys)
(apply 'make-pathname :defaults (wilden *asdf-directory*) keys))
(setf (logical-pathname-translations "ASDF")
#+(or allegro clisp)
`(("**;*.*.*" ,(asdf::wilden *asdf-directory*)))
#-(or allegro clisp)
`(("**;*.asd.*" ,(make-pathname :type "asd" :defaults (asdf::wilden *asdf-directory*)))
("**;*.lisp.*" ,(make-pathname :type "lisp" :defaults (asdf::wilden *asdf-directory*)))
`(("**;*.asd.*" ,(wild :type "asd"))
("**;*.lisp.*" ,(wild :type "lisp"))
("**;*.*.*" ,(resolve-location
`(,*asdf-directory* "build/fasls" :implementation "logical-host-asdf")
:wilden t))))
...
...
@@ -19,12 +19,14 @@
(translate-logical-pathname "ASDF:test;test-logical-pathname.lisp")
(translate-logical-pathname "ASDF:test;test-logical-pathname.fasl"))
#+(or
clisp
gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0)
#+(or gcl xcl) (leave-test "This implementation doesn't do Logical pathnames well enough" 0)
(DBG "Test logical pathnames in central registry")
(clear-system :test-logical-pathname)
(setf *central-registry* '(#p"ASDF:test;"))
(assert (logical-pathname-p (first *central-registry*)))
(initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(DBG "loading" (
oos 'load-op
:test-logical-pathname :force t))
(DBG "loading" (
load-system
:test-logical-pathname :force t))
(DBG "Test logical pathnames in source-registry, non-recursive")
(clear-system :test-logical-pathname)
...
...
@@ -45,7 +47,7 @@
:ignore-inherited-configuration))
(load-system :test-logical-pathname :force t)
#+
(or clisp
abcl
)
(leave-test "
CLISP and
ABCL translate logical pathnames in *LOAD-PATHNAME*" 0)
#+abcl (leave-test "ABCL translate
s
logical pathnames in *LOAD-PATHNAME*" 0)
(defparameter sys (find-system :test-logical-pathname))
(assert (logical-pathname-p (component-pathname sys)))
...
...
uiop/filesystem.lisp
View file @
d88e4273
...
...
@@ -601,13 +601,16 @@ NILs."
(
defun
rename-file-overwriting-target
(
source
target
)
"Rename a file, overwriting any previous file with the TARGET name,
in an atomic way if the implementation allows."
#+
clisp
;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
(
progn
(
funcall
'require
"syscalls"
)
(
symbol-call
:posix
:copy-file
source
target
:method
:rename
))
#+
(
and
sbcl
os-windows
)
(
delete-file-if-exists
target
)
;; not atomic
#-
clisp
(
rename-file
source
target
#+
(
or
clasp
clozure
ecl
)
:if-exists
#+
clozure
:rename-and-delete
#+
(
or
clasp
ecl
)
t
))
(
let
((
source
(
ensure-pathname
source
:namestring
:lisp
:ensure-physical
t
:want-file
t
))
(
target
(
ensure-pathname
target
:namestring
:lisp
:ensure-physical
t
:want-file
t
)))
#+
clisp
;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic
(
progn
(
funcall
'require
"syscalls"
)
(
symbol-call
:posix
:copy-file
source
target
:method
:rename
))
#+
(
and
sbcl
os-windows
)
(
delete-file-if-exists
target
)
;; not atomic
#-
clisp
(
rename-file
source
target
#+
(
or
clasp
clozure
ecl
)
:if-exists
#+
clozure
:rename-and-delete
#+
(
or
clasp
ecl
)
t
)))
(
defun
delete-empty-directory
(
directory-pathname
)
"Delete an empty directory"
...
...
uiop/lisp-build.lisp
View file @
d88e4273
...
...
@@ -667,6 +667,7 @@ it will filter them appropriately."
(
output-file
(
or
output-file
(
apply
'compile-file-pathname*
input-file
:output-file
output-file
keywords
)))
(
physical-output-file
(
physicalize-pathname
output-file
))
#+
(
or
clasp
ecl
)
(
object-file
(
unless
(
use-ecl-byte-compiler-p
)
...
...
@@ -677,11 +678,11 @@ it will filter them appropriately."
(
object-file
(
or
object-file
(
compile-file-pathname
output-file
:fasl-p
nil
)))
(
tmp-file
(
tmpize-pathname
output-file
))
(
tmp-file
(
tmpize-pathname
physical-
output-file
))
#+
sbcl
(
cfasl-file
(
etypecase
emit-cfasl
(
null
nil
)
((
eql
t
)
(
make-pathname
:type
"cfasl"
:defaults
output-file
))
((
eql
t
)
(
make-pathname
:type
"cfasl"
:defaults
physical-
output-file
))
(
string
(
parse-namestring
emit-cfasl
))
(
pathname
emit-cfasl
)))
#+
sbcl
...
...
@@ -720,17 +721,23 @@ it will filter them appropriately."
#+
(
or
clasp
ecl
)
:lisp-files
#+
mkcl
:lisp-object-files
(
list
object-file
))))
(
or
(
not
compile-check
)
(
apply
compile-check
input-file
:output-file
#-
(
or
clasp
ecl
)
output-file
#+
(
or
clasp
ecl
)
tmp-fil
e
:output-file
output-truenam
e
keywords
))))
(
delete-file-if-exists
output-file
)
(
delete-file-if-exists
physical-
output-file
)
(
when
output-truename
#+
clasp
(
when
output-truename
(
rename-file-overwriting-target
tmp-file
output-truename
))
#+
clisp
(
when
lib-file
(
rename-file-overwriting-target
tmp-lib
lib-file
))
;; see CLISP bug 677
#+
clisp
(
progn
(
setf
tmp-lib
(
make-pathname
:type
"lib"
:defaults
output-truename
))
(
unless
lib-file
(
setf
lib-file
(
make-pathname
:type
"lib"
:defaults
physical-output-file
)))
(
rename-file-overwriting-target
tmp-lib
lib-file
))
#+
sbcl
(
when
cfasl-file
(
rename-file-overwriting-target
tmp-cfasl
cfasl-file
))
(
rename-file-overwriting-target
output-truename
output-file
)
(
setf
output-truename
(
truename
output-file
)))
(
rename-file-overwriting-target
output-truename
physical-
output-file
)
(
setf
output-truename
(
truename
physical-
output-file
)))
#+
clasp
(
delete-file-if-exists
tmp-file
)
#+
clisp
(
delete-file-if-exists
tmp-lib
))
#+
clisp
(
progn
(
delete-file-if-exists
tmp-file
)
;; this one works around clisp BUG 677
(
delete-file-if-exists
tmp-lib
)))
;; this one is "normal" defensive cleanup
(
t
;; error or failed check
(
delete-file-if-exists
output-truename
)
#+
clisp
(
delete-file-if-exists
tmp-lib
)
...
...
uiop/stream.lisp
View file @
d88e4273
...
...
@@ -579,7 +579,11 @@ Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'e
(
loop
:with
prefix-pn
=
(
ensure-absolute-pathname
(
or
prefix
"tmp"
)
(
or
(
ensure-pathname
directory
:namestring
:native
:ensure-directory
t
)
(
or
(
ensure-pathname
directory
:namestring
:native
:ensure-directory
t
:ensure-physical
t
)
#'
temporary-directory
))
:with
prefix-nns
=
(
native-namestring
prefix-pn
)
:with
results
=
(
progn
(
ensure-directories-exist
prefix-pn
)
...
...
@@ -679,9 +683,9 @@ Further KEYS can be passed to MAKE-PATHNAME."
"Return a new pathname modified from X by adding a trivial random suffix.
A new empty file with said temporary pathname is created, to ensure there is no
clash with any concurrent process attempting the same thing."
(
let*
((
px
(
ensure-pathname
x
))
(
let*
((
px
(
ensure-pathname
x
:ensure-physical
t
))
(
prefix
(
if-let
(
n
(
pathname-name
px
))
(
strcat
n
"-tmp"
)
"tmp"
))
(
directory
(
translate-logical-pathname
(
pathname-directory-pathname
px
)))
)
(
directory
(
pathname-directory-pathname
px
)))
(
get-temporary-file
:directory
directory
:prefix
prefix
:type
(
pathname-type
px
))))
(
defun
call-with-staging-pathname
(
pathname
fun
)
...
...
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