Commit b1ffbc47 authored by Robert Goldman's avatar Robert Goldman
Browse files

Further UIOP directory path fixes.

These from Spencer Truex, with tests by me.
parent 0bda58ed
;;; -*- Lisp -*- ;;; -*- Lisp -*-
(in-package :asdf-test)
;; the following should not be necessary, because of `frob-packages`
;; call, but somehow is. [2019/06/25:rpg]
(use-package :uiop :asdf-test)
(proclaim '(optimize (debug 3) (speed 1) (safety 3) (compilation-speed 0))) (proclaim '(optimize (debug 3) (speed 1) (safety 3) (compilation-speed 0)))
(defun getcwd-from-run-program () (defun getcwd-from-run-program ()
...@@ -318,9 +321,7 @@ ...@@ -318,9 +321,7 @@
(assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))) (assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2")))
(DBG "check to make sure DIRECTORY-FILES doesn't list subdirectories") (DBG "check to make sure DIRECTORY-FILES doesn't list subdirectories")
(let ((directory-a (directory-files (subpathname *build-directory* "deleteme/a/"))) (let ((directory-a (directory-files (subpathname *build-directory* "deleteme/a/")))
(directory-a-no-slash (directory-files (subpathname *build-directory* "deleteme/a"))) (directory-b (directory-files (subpathname *build-directory* "deleteme/a/b/"))))
(directory-b (directory-files (subpathname *build-directory* "deleteme/a/b/")))
(directory-b-no-slash (directory-files (subpathname *build-directory* "deleteme/a/b"))))
(assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/1.x"))) (assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/1.x")))
(assert-pathnames-equal directory-b (list (subpathname *build-directory* "deleteme/a/b/2")))) (assert-pathnames-equal directory-b (list (subpathname *build-directory* "deleteme/a/b/2"))))
(DBG "check to make sure DIRECTORY-FILES checks its parameter for directory pathname") (DBG "check to make sure DIRECTORY-FILES checks its parameter for directory pathname")
...@@ -328,10 +329,31 @@ ...@@ -328,10 +329,31 @@
(directory-b-no-slash (directory-files (subpathname *build-directory* "deleteme/a/b")))) (directory-b-no-slash (directory-files (subpathname *build-directory* "deleteme/a/b"))))
(assert-pathnames-equal directory-a-no-slash (list (subpathname *build-directory* "deleteme/a/1.x"))) (assert-pathnames-equal directory-a-no-slash (list (subpathname *build-directory* "deleteme/a/1.x")))
(assert-pathnames-equal directory-b-no-slash (list (subpathname *build-directory* "deleteme/a/b/2")))) (assert-pathnames-equal directory-b-no-slash (list (subpathname *build-directory* "deleteme/a/b/2"))))
(DBG "check to make sure WITH-CURRENT-DIRECTORY checks its parameter for directory pathname")
(let ((directory-a-no-slash (subpathname *build-directory* "deleteme/a"))
(directory-b-no-slash (subpathname *build-directory* "deleteme/a/b")))
(assert (eq 'with-current-directory 'uiop:with-current-directory))
(with-current-directory (directory-a-no-slash)
(assert-pathnames-equal (directory-files (getcwd)) (list (subpathname *build-directory* "deleteme/a/1.x"))))
(with-current-directory (directory-b-no-slash)
(assert-pathnames-equal (directory-files (getcwd)) (list (subpathname *build-directory* "deleteme/a/b/2")))
(assert-pathnames-equal
(sort (subdirectories (getcwd)) #'string< :key #'(lambda (x) (car (last (pathname-directory x)))))
(list (subpathname *build-directory* "deleteme/a/b/c/")
(subpathname *build-directory* "deleteme/a/b/d/")
(subpathname *build-directory* "deleteme/a/b/e/")))))
(DBG "check to make sure SUBDIRECTORIES does list subdirectories") (DBG "check to make sure SUBDIRECTORIES does list subdirectories")
(let ((directory-a (subdirectories (subpathname *build-directory* "deleteme/a/"))) (let ((directory-a (subdirectories (subpathname *build-directory* "deleteme/a/")))
(directory-b (subdirectories (subpathname *build-directory* "deleteme/a/b/")))) (directory-b (subdirectories (subpathname *build-directory* "deleteme/a/b/"))))
(assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/b/"))) (assert-pathnames-equal directory-a (list (subpathname *build-directory* "deleteme/a/b/")))
;; trailing slash should not be necessary...
(assert-pathnames-equal (subdirectories (subpathname *build-directory* "deleteme/a"))
(list (subpathname *build-directory* "deleteme/a/b/")))
(assert-pathnames-equal (assert-pathnames-equal
(sort directory-b #'string< :key #'(lambda (x) (car (last (pathname-directory x))))) (sort directory-b #'string< :key #'(lambda (x) (car (last (pathname-directory x)))))
(list (subpathname *build-directory* "deleteme/a/b/c/") (list (subpathname *build-directory* "deleteme/a/b/c/")
......
...@@ -490,7 +490,10 @@ resolving them with respect to GETCWD if the DEFAULTS were relative" ...@@ -490,7 +490,10 @@ resolving them with respect to GETCWD if the DEFAULTS were relative"
"call the THUNK in a context where the current directory was changed to DIR, if not NIL. "call the THUNK in a context where the current directory was changed to DIR, if not NIL.
Note that this operation is usually NOT thread-safe." Note that this operation is usually NOT thread-safe."
(if dir (if dir
(let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir)))) (let* ((dir (resolve-symlinks*
(get-pathname-defaults
(ensure-directory-pathname
dir))))
(cwd (getcwd)) (cwd (getcwd))
(*default-pathname-defaults* dir)) (*default-pathname-defaults* dir))
(chdir dir) (chdir dir)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment