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
Package Registry
Model registry
Operate
Environments
Terraform modules
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
Tarn Burton
asdf
Commits
4fc1e719
Commit
4fc1e719
authored
9 years ago
by
Francois-Rene Rideau
Browse files
Options
Downloads
Patches
Plain Diff
uiop: make probe-file* and truename* more robust
parent
f73f7d8b
No related branches found
No related tags found
No related merge requests found
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
TODO
+1
-0
1 addition, 0 deletions
TODO
test/script-support.lisp
+2
-2
2 additions, 2 deletions
test/script-support.lisp
test/test-utilities.script
+88
-13
88 additions, 13 deletions
test/test-utilities.script
uiop/filesystem.lisp
+54
-57
54 additions, 57 deletions
uiop/filesystem.lisp
with
145 additions
and
72 deletions
TODO
+
1
−
0
View file @
4fc1e719
...
@@ -113,6 +113,7 @@
...
@@ -113,6 +113,7 @@
*** it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL???
*** it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL???
** XCL has bad bugs:
** XCL has bad bugs:
*** it can't compile ASDF3 anymore. Figure out why, if you have time.
*** make-pathname doesn't handle :type nil properly and
*** make-pathname doesn't handle :type nil properly and
has massive lossage in logical-pathname support.
has massive lossage in logical-pathname support.
*** If using block () and return in search-for-system-definition
*** If using block () and return in search-for-system-definition
...
...
This diff is collapsed.
Click to expand it.
test/script-support.lisp
+
2
−
2
View file @
4fc1e719
...
@@ -168,14 +168,14 @@ Some constraints:
...
@@ -168,14 +168,14 @@ Some constraints:
qx
x
(
pathname-components
x
)
qx
x
(
pathname-components
x
)
qy
y
(
pathname-components
y
)))
qy
y
(
pathname-components
y
)))
;; accept equalp namestrings, to account for case-independent filesystems
;; accept equalp namestrings, to account for case-independent filesystems
((
equalp
(
namestring
x
)
(
namestring
y
))
((
equalp
(
and
x
(
namestring
x
)
)
(
and
y
(
namestring
y
))
)
(
warn
"These two expressions yield pathnames that have equalp namestrings yet are not pathname-equal~%~
(
warn
"These two expressions yield pathnames that have equalp namestrings yet are not pathname-equal~%~
the first expression ~S yields this:~% ~S~% ~S~%
the first expression ~S yields this:~% ~S~% ~S~%
the other expression ~S yields that:~% ~S~% ~S~%"
the other expression ~S yields that:~% ~S~% ~S~%"
qx
x
(
pathname-components
x
)
qx
x
(
pathname-components
x
)
qy
y
(
pathname-components
y
)))
qy
y
(
pathname-components
y
)))
(
t
(
t
(
error
"These two expressions yield paths that are equal in any way:~%~
(
error
"These two expressions yield paths that are
not
equal in any way:~%~
the first expression ~S yields this:~% ~S~% ~S~%
the first expression ~S yields this:~% ~S~% ~S~%
the other expression ~S yields that:~% ~S~% ~S~%"
the other expression ~S yields that:~% ~S~% ~S~%"
qx
x
(
pathname-components
x
)
qx
x
(
pathname-components
x
)
...
...
This diff is collapsed.
Click to expand it.
test/test-utilities.script
+
88
−
13
View file @
4fc1e719
;;; -*- Lisp -*-
;;; -*- Lisp -*-
#+(and sbcl os-windows) (trace sb-ext:run-program)
#+(and sbcl os-windows) (trace sb-ext:run-program)
(proclaim '(optimize (debug 3) (speed 1) (safety 3) (compilation-speed 0)))
(defun getcwd-from-run-program ()
(defun getcwd-from-run-program ()
(uiop:parse-native-namestring
(uiop:parse-native-namestring
...
@@ -14,19 +15,93 @@
...
@@ -14,19 +15,93 @@
:output '(:string :stripped t)))
:output '(:string :stripped t)))
:ensure-directory t))
:ensure-directory t))
(let ((asdf-directory (truename *asdf-directory*)))
(let ((asdf-directory (truename *asdf-directory*))
(chdir asdf-directory)
(test-directory (truename *test-directory*)))
(assert-pathname-equal asdf-directory (getcwd))
(labels ((check-cwd (dir)
#-(and sbcl os-windows)
(assert-pathname-equal dir (getcwd))
(assert-pathname-equal asdf-directory (getcwd-from-run-program))
#-(and sbcl os-windows)
(assert (probe-file* "asdf.asd")))
(assert-pathname-equal dir (getcwd-from-run-program)))
(check-true-dpd (dir)
(let ((test-directory (truename *test-directory*)))
(assert-pathname-equal dir (get-pathname-defaults))
(chdir test-directory)
(assert-pathname-equal dir (truename #p"./"))
(assert-pathname-equal test-directory (getcwd))
(assert-pathname-equal dir (truename* #p"./")))
#-(and sbcl os-windows)
(check-file-exists (file &optional true)
(assert-pathname-equal test-directory (getcwd-from-run-program))
(setf file (parse-unix-namestring file))
(assert (probe-file* "test-utilities.script")))
(if true
(assert-pathname-equal true (probe-file file))
(setf true (probe-file file)))
(assert-pathname-equal true (truename file))
(assert-pathname-equal true (truename* file))
(assert-pathname-equal true (probe-file* file :truename t))
(assert-pathname-equal true (ensure-absolute-pathname (probe-file* file) 'get-pathname-defaults)))
(check-file-doesnt-exist (file)
(setf file (parse-unix-namestring file))
(assert-equal nil (probe-file* file))
(assert-equal nil (probe-file file)))
(check-directory-exists (file &optional true)
(setf file (parse-unix-namestring file))
(let ((dir (truename (ensure-directory-pathname file))))
(if true
(assert-pathname-equal true dir)
(setf true dir)))
(assert-pathname-equal true (truename (ensure-directory-pathname file)))
(assert-pathname-equal true (truename* file))
(assert-pathname-equal true (nest #+allegro (ensure-directory-pathname) (probe-file* file :truename t)))
(assert-pathname-equal true (if-let (x (probe-file* file))
(ensure-absolute-pathname (ensure-directory-pathname x) 'get-pathname-defaults))))
(check-directory-doesnt-exist (file)
(setf file (parse-unix-namestring file))
(assert-equal nil (probe-file* file)))
(check-true-dpd-asdf ()
(check-true-dpd asdf-directory)
(check-file-exists "asdf.asd")
(check-file-exists "test/test-utilities.script")
(check-directory-exists "tools/")
(check-directory-exists "tools")
(check-file-doesnt-exist "test-utilities.script")
(check-directory-doesnt-exist "stamp-propagation/"))
(check-true-dpd-test ()
(check-true-dpd test-directory)
(check-file-exists "test-utilities.script")
(check-directory-exists "stamp-propagation/")
(check-directory-exists "stamp-propagation")
(check-file-doesnt-exist "test/test-utilities.script")
(check-directory-doesnt-exist "tools/")))
(DBG "1" (chdir asdf-directory) (setf *default-pathname-defaults* asdf-directory))
(check-true-dpd-asdf)
(DBG "2" (chdir test-directory) (setf *default-pathname-defaults* test-directory))
(check-true-dpd-test)
(with-expected-failure (#+gcl t)
(DBG "3" (chdir asdf-directory) (setf *default-pathname-defaults* test-directory))
(check-true-dpd-test))
#-(or abcl genera xcl) ;; on these platforms, chdir changes D-P-D so these tests are not meaningful
(progn
;; SBCL hates to get (truename #p"") when D-P-D is itself #p"". See https://bugs.launchpad.net/sbcl/+bug/1472414
(DBG "4"
(setf *default-pathname-defaults* (nil-pathname)) ;; make things relative to GETCWD
(chdir asdf-directory)) ;; note: may or may not change *default-pathname-defaults* to an absolute pathname.
(check-true-dpd-asdf)
(DBG "5"
*default-pathname-defaults*
(chdir test-directory)) ;; note: may or may not change *default-pathname-defaults* to an absolute pathname.
(check-true-dpd-test)
;; On implementations where chdir doesn't side-effect D-P-D, we can have D-P-D be relative to GETCWD...
;; except on allegro, that hates this trick.
(with-expected-failure (#+(or allegro gcl) t)
(unless (absolute-pathname-p *default-pathname-defaults*)
(DBG "6"
(chdir asdf-directory)
(setf *default-pathname-defaults* (parse-unix-namestring "test/")))
(check-true-dpd-test))))
;; For the rest of this test, use these:
(setf *default-pathname-defaults* (nil-pathname))
(chdir test-directory)))
(assert
(assert
(every #'directory-pathname-p
(every #'directory-pathname-p
...
...
This diff is collapsed.
Click to expand it.
uiop/filesystem.lisp
+
54
−
57
View file @
4fc1e719
...
@@ -64,9 +64,12 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
...
@@ -64,9 +64,12 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
;;; Probing the filesystem
;;; Probing the filesystem
(
with-upgradability
()
(
with-upgradability
()
(
defun
truename*
(
p
)
(
defun
truename*
(
p
)
"Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts"
"Nicer variant of TRUENAME that plays well with NIL, avoids logical pathname contexts, and tries both files and directories"
;; avoids both logical-pathname merging and physical resolution issues
(
when
p
(
and
p
(
handler-case
(
with-pathname-defaults
()
(
truename
p
))
(
file-error
()
nil
))))
(
when
(
stringp
p
)
(
setf
p
(
with-pathname-defaults
()
(
parse-namestring
p
))))
(
values
(
or
(
ignore-errors
(
truename
p
))
#+
(
or
clisp
gcl
)
(
if-let
(
d
(
ensure-directory-pathname
p
))
(
ignore-errors
(
truename
d
)))))))
(
defun
safe-file-write-date
(
pathname
)
(
defun
safe-file-write-date
(
pathname
)
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
"Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error."
...
@@ -87,60 +90,54 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
...
@@ -87,60 +90,54 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
probes the filesystem for a file or directory with given pathname.
probes the filesystem for a file or directory with given pathname.
If it exists, return its truename is ENSURE-PATHNAME is true,
If it exists, return its truename is ENSURE-PATHNAME is true,
or the original (parsed) pathname if it is false (the default)."
or the original (parsed) pathname if it is false (the default)."
(
etypecase
p
(
values
(
null
nil
)
(
ignore-errors
(
string
(
setf
p
(
funcall
'ensure-pathname
p
;; avoid logical-pathname issues on some implementations
:namestring
:lisp
(
let
((
pn
(
with-pathname-defaults
()
(
parse-namestring
p
))))
:ensure-physical
t
(
probe-file*
pn
:truename
truename
)))
:ensure-absolute
t
:defaults
'get-pathname-defaults
(
pathname
:want-non-wild
t
(
and
(
not
(
wild-pathname-p
p
))
:on-error
nil
))
(
handler-case
(
when
p
(
or
#+
allegro
#+
allegro
(
probe-file
p
:follow-symlinks
truename
)
(
probe-file
p
:follow-symlinks
truename
)
#+
gcl
#+
gcl
(
if
truename
(
if
truename
(
truename*
p
)
(
truename*
p
)
(
let
((
kind
(
car
(
si::stat
p
))))
(
let
((
kind
(
car
(
si::stat
p
))))
(
when
(
eq
kind
:link
)
(
when
(
eq
kind
:link
)
(
setf
kind
(
ignore-errors
(
car
(
si::stat
(
truename*
p
))))))
(
setf
kind
(
ignore-errors
(
car
(
si::stat
(
truename*
p
))))))
(
ecase
kind
(
ecase
kind
((
nil
)
nil
)
((
nil
)
nil
)
((
:file
:link
)
((
:file
:link
)
(
cond
(
cond
((
file-pathname-p
p
)
p
)
((
file-pathname-p
p
)
p
)
((
directory-pathname-p
p
)
((
directory-pathname-p
p
)
(
subpathname
p
(
car
(
last
(
pathname-directory
p
)))))))
(
subpathname
p
(
car
(
last
(
pathname-directory
p
)))))))
(
:directory
(
ensure-directory-pathname
p
)))))
(
:directory
(
ensure-directory-pathname
p
)))))
#+
clisp
#+
clisp
#.
(
let*
((
fs
(
or
#-
os-windows
(
find-symbol*
'
#:file-stat
:posix
nil
)))
#.
(
let*
((
fs
(
or
#-
os-windows
(
find-symbol*
'
#:file-stat
:posix
nil
)))
(
pp
(
find-symbol*
'
#:probe-pathname
:ext
nil
)))
(
pp
(
find-symbol*
'
#:probe-pathname
:ext
nil
)))
`
(
if
truename
`
(
if
truename
,
(
if
pp
,
(
if
pp
`
(
values
(
,
pp
p
))
`
(
ignore-errors
(
,
pp
p
))
'
(
or
(
truename*
p
)
'
(
or
(
truename*
p
)
(
truename*
(
ignore-errors
(
ensure-directory-pathname
p
)))))
(
truename*
(
ignore-errors
(
ensure-directory-pathname
p
)))))
,
(
cond
,
(
cond
(
fs
`
(
and
(
,
fs
p
)
p
))
(
fs
`
(
and
(
ignore-errors
(
,
fs
p
))
p
))
(
pp
`
(
nth-value
1
(
,
pp
p
)))
(
pp
`
(
ignore-errors
(
nth-value
1
(
,
pp
p
))))
(
t
'
(
or
(
and
(
truename*
p
)
p
)
(
t
'
(
if-let
(
q
(
ensure-absolute-pathname
p
(
if-let
(
d
(
ensure-directory-pathname
p
))
:defaults
'get-pathname-defaults
:on-error
nil
))
(
and
(
truename*
d
)
d
)))))))
(
or
(
and
(
truename*
q
)
q
)
#-
(
or
allegro
clisp
gcl
)
(
if-let
(
d
(
ignore-errors
(
ensure-directory-pathname
q
)))
(
if
truename
(
and
(
truename*
d
)
d
))))))))
(
probe-file
p
)
#-
(
or
allegro
clisp
gcl
)
(
and
(
if
truename
#+
(
or
cmu
scl
)
(
unix:unix-stat
(
ext:unix-namestring
p
))
(
probe-file
p
)
#+
(
and
lispworks
unix
)
(
system:get-file-stat
p
)
(
ignore-errors
#+
sbcl
(
sb-unix:unix-stat
(
sb-ext:native-namestring
p
))
(
let
((
pp
(
physicalize-pathname
p
)))
#-
(
or
cmu
(
and
lispworks
unix
)
sbcl
scl
)
(
file-write-date
p
)
(
and
p
))))))
#+
(
or
cmu
scl
)
(
unix:unix-stat
(
ext:unix-namestring
pp
))
#+
(
and
lispworks
unix
)
(
system:get-file-stat
pp
)
#+
sbcl
(
sb-unix:unix-stat
(
sb-ext:native-namestring
pp
))
#-
(
or
cmu
(
and
lispworks
unix
)
sbcl
scl
)
(
file-write-date
pp
)
p
)))))
(
file-error
()
nil
))))))
(
defun
directory-exists-p
(
x
)
(
defun
directory-exists-p
(
x
)
"Is X the name of a directory that exists on the filesystem?"
"Is X the name of a directory that exists on the filesystem?"
...
...
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