make more path tests run on all platforms, use system-idle-evt for some sync tests
svn: r4926
This commit is contained in:
Matthew Flatt
parent
46fed6e891
commit
94adeb1d13
|
|
@ -125,7 +125,7 @@
|
|||
'expand-load
|
||||
#f
|
||||
(lambda ()
|
||||
(namespace-set-variable-value! 'expand-load "quiet.ss")))
|
||||
(namespace-set-variable-value! 'expand-load "mz.ss")))
|
||||
|
||||
(let ([orig (current-eval)])
|
||||
(dynamic-wind
|
||||
|
|
|
|||
|
|
@ -418,8 +418,6 @@
|
|||
(path->string
|
||||
(normal-case-path (simplify-path (expand-path (current-directory))))))
|
||||
"")]
|
||||
[get-base (lambda (s)
|
||||
(let-values ([(base name dir?) (split-path s)]) (list base name)))]
|
||||
[drive (path->string (current-drive))])
|
||||
|
||||
(test #t directory-exists? here)
|
||||
|
|
@ -480,185 +478,6 @@
|
|||
(test (string->path "\\\\?\\REL\\a\\\\\\a") path->complete-path "\\a")
|
||||
)
|
||||
|
||||
(test (bytes->path #"c:\\a") path->complete-path "\\a" "c:")
|
||||
(test (bytes->path #"\\\\foo\\bar\\a") path->complete-path "\\a" "\\\\foo\\bar\\a")
|
||||
|
||||
;; Build path collapses .. and . in added parts and cleans up slashes and trailers:
|
||||
(test (string->path "\\\\?\\c:\\a\\b") build-path "\\\\?\\c:\\a" 'same "b")
|
||||
(test (string->path "\\\\?\\c:\\a\\b") build-path "\\\\?\\c:\\a\\" 'same "b")
|
||||
(test (string->path "\\\\?\\c:\\a\\.\\b") build-path "\\\\?\\c:\\a\\." 'same "b")
|
||||
(test (string->path "\\\\?\\c:\\a\\.\\b") build-path "\\\\?\\c:\\a\\.\\" 'same "b")
|
||||
(test (string->path "\\\\?\\c:\\b") build-path "\\\\?\\c:\\a\\" 'up "b")
|
||||
(test (string->path "\\\\?\\c:\\a\\b") build-path "\\\\?\\c:\\a\\.\\" 'up "b")
|
||||
(test (string->path "\\\\?\\c:\\b") build-path "\\\\?\\c:\\a\\.\\" 'up 'up 'up "b")
|
||||
(test (string->path "\\\\?\\c:\\a\\b\\c\\d\\f\\") build-path "\\\\?\\c:\\a" "b//c" "d//\\f///")
|
||||
(test (string->path "\\\\?\\c:\\a\\foo") build-path "\\\\?\\c:\\a" "foo... ")
|
||||
|
||||
(test (string->path "\\\\?\\REL\\\\a") build-path "." "\\\\?\\REL\\a")
|
||||
(test (string->path "\\\\?\\REL\\\\a") build-path 'same "\\\\?\\REL\\a")
|
||||
(test (string->path "\\\\?\\REL\\\\a\\") build-path "\\\\?\\REL\\a" 'same)
|
||||
(test (string->path ".") build-path "\\\\?\\REL\\a" 'up)
|
||||
(test (string->path "\\\\?\\REL\\\\apple") build-path "\\\\?\\REL\\a" 'up "apple")
|
||||
(test (string->path ".") build-path "\\\\?\\REL\\a" 'up 'same)
|
||||
|
||||
(test (string->path "\\\\?\\REL\\..\\\\a") build-path 'up "\\\\?\\REL\\a")
|
||||
(test (string->path "\\\\?\\REL\\..\\\\..") build-path 'up "\\\\?\\REL\\\\..")
|
||||
(test (string->path "\\\\?\\REL\\..\\..") build-path 'up "\\\\?\\REL\\..")
|
||||
(test (string->path "\\\\?\\REL\\..\\..") build-path "\\\\?\\REL\\.." 'up)
|
||||
(test (string->path "\\\\?\\REL\\..\\..\\..") build-path 'up "\\\\?\\REL\\.." 'up)
|
||||
(test (string->path "\\\\?\\REL\\..\\..\\\\..") build-path 'up "\\\\?\\REL\\.." "\\\\?\\REL\\\\..")
|
||||
(test (string->path "\\\\?\\REL\\..\\..") build-path 'up "\\\\?\\REL\\.." "\\\\?\\REL\\\\.." 'up)
|
||||
(test (string->path "\\\\?\\REL\\\\..\\") build-path "\\\\?\\REL\\\\.." "\\\\?\\REL\\\\.." 'up)
|
||||
(test (string->path "\\\\?\\REL\\\\x\\") build-path "x/y" "\\\\?\\REL\\..")
|
||||
(test (string->path "\\\\?\\c:\\x\\") build-path "c:x/y" "\\\\?\\REL\\..")
|
||||
|
||||
(test-values (list (string->path "\\\\?\\REL\\..")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path "\\\\?\\REL\\..\\a")))
|
||||
(test-values (list (string->path "\\\\?\\REL\\..")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path "\\\\?\\REL\\..\\\\a")))
|
||||
(test-values (list (string->path "\\\\?\\REL\\b\\")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path "\\\\?\\REL\\b\\a")))
|
||||
|
||||
(test (string->path "\\\\?\\UNC\\f\\g") build-path "//f/g/h" "\\\\?\\REL\\..")
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\") build-path "//f/g/h/i" "\\\\?\\REL\\..")
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\..") build-path "//f/g/h" "\\\\?\\REL\\\\..")
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\..") build-path "//f/g//h" "\\\\?\\REL\\\\..")
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\i\\x") build-path "//f/g/h/../i" "\\\\?\\REL\\x")
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\i\\x") build-path "//f/g/../h/i" "\\\\?\\REL\\x")
|
||||
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\")) build-path "/f/g/h" "\\\\?\\REL\\..")
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\h\\x")) build-path "/f/g/h" "\\\\?\\REL\\x")
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\h\\x")) build-path "//f//g/h" "\\\\?\\REL\\x")
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\h\\x")) build-path "/f//g////h" "\\\\?\\REL\\x")
|
||||
(test (string->path (string-append "\\\\?\\" drive)) build-path "/f//g////h" "\\\\?\\REL\\..\\..\\..\\..")
|
||||
(test (string->path (string-append "\\\\?\\" drive "?\\g\\h\\x")) build-path "//?/g/h" "\\\\?\\REL\\x")
|
||||
|
||||
;; Allow \\?\ as a drive to add an absolute path:
|
||||
(test (string->path "\\\\?\\c:\\b") build-path "\\\\?\\c:\\" "\\b")
|
||||
(test (string->path "\\\\?\\c:\\b") build-path "\\\\?\\c:\\\\" "\\b")
|
||||
(test (string->path "\\\\?\\c:\\b\\") build-path "\\\\?\\c:\\\\" "\\b\\")
|
||||
(test (string->path "\\\\?\\UNC\\goo\\bar\\b") build-path "\\\\?\\UNC\\goo\\bar" "\\b")
|
||||
(test (string->path "\\\\?\\\\b") build-path "\\\\?\\" "\\b")
|
||||
(test (string->path "\\\\?\\\\b\\") build-path "\\\\?\\" "\\b\\")
|
||||
(err/rt-test (build-path "\\\\?\\c:" "\\b") exn:fail:contract?)
|
||||
|
||||
;; Don't allow path addition on bad \\?\ to change the root:
|
||||
(test (string->path "\\\\?\\\\c") build-path "\\\\?\\" "c")
|
||||
(test (string->path "\\\\?\\\\UNC") build-path "\\\\?\\" "UNC")
|
||||
(test (string->path "\\\\?\\\\UNC\\s\\y") build-path "\\\\?\\UNC" "s/y")
|
||||
(test (string->path "\\\\?\\\\UNC\\s\\y") build-path "\\\\?\\UNC\\" "s/y")
|
||||
(test (string->path "\\\\?\\\\REL\\s\\y") build-path "\\\\?\\REL" "s/y")
|
||||
(test (string->path "\\\\?\\\\REL\\s\\y") build-path "\\\\?\\REL\\" "s/y")
|
||||
(test (string->path "\\\\?\\REL\\\\\\s\\y") build-path "\\\\?\\REL\\\\" "s/y")
|
||||
(test (string->path "\\\\?\\REL\\x\\\\\\z") build-path "\\\\?\\REL\\x\\\\" "z")
|
||||
(test (string->path "/apple\\x") build-path "//apple" "x")
|
||||
(test (string->path "\\\\?") build-path "\\\\" "?")
|
||||
(test (string->path "\\?\\") build-path "\\\\" "?\\")
|
||||
(test (string->path "\\?\\a") build-path "\\\\" "?" "a")
|
||||
(test (string->path "\\?\\a") build-path "\\\\?" "a")
|
||||
(test (string->path "\\?\\a\\") build-path "\\\\?" "a\\")
|
||||
(test (string->path "\\\\?\\\\c:") build-path "\\\\?\\" "\\\\?\\REL\\c:")
|
||||
(test (string->path "\\\\?\\\\c:\\a") build-path "\\\\?\\" "\\\\?\\REL\\c:\\a")
|
||||
(test (string->path "\\\\?\\\\REL\\b") build-path "\\\\?\\" "\\\\?\\REL\\REL\\b")
|
||||
(test (string->path "\\\\?\\\\host\\vol\\a\\") build-path "\\\\?\\" "\\\\?\\REL\\\\host\\vol\\a\\")
|
||||
|
||||
;; UNC paths can't have "?" for machine or "/" in machine part:
|
||||
(test (list (string->path "/?/") (string->path "x")) get-base "//?/x")
|
||||
(test (list (string->path "\\\\?\\UNC\\a/b\\") (string->path "x")) get-base "\\\\?\\UNC\\a/b\\x")
|
||||
|
||||
;; Split path must treat \\?\ part as a root:
|
||||
(test (list (string->path "\\\\?\\c:\\") (string->path "a")) get-base "\\\\?\\c:\\a")
|
||||
(test (list (string->path "\\\\?\\") (string->path "\\\\?\\REL\\\\c:")) get-base "\\\\?\\c:")
|
||||
(test (list #f (string->path "\\\\?\\c:\\")) get-base "\\\\?\\c:\\")
|
||||
(test (list #f (string->path "\\\\?\\c:\\\\")) get-base "\\\\?\\c:\\\\")
|
||||
(test (list (string->path "\\\\?\\c:\\") (string->path "a")) get-base "\\\\?\\c:\\\\a")
|
||||
(test (list #f (string->path "\\\\?\\UNC\\mach\\vol")) get-base "\\\\?\\UNC\\mach\\vol")
|
||||
(test (list #f (string->path "\\\\?\\UNC\\mach\\\\vol")) get-base "\\\\?\\UNC\\mach\\\\vol")
|
||||
(test (list #f (string->path "\\\\?\\UNC\\\\mach\\vol")) get-base "\\\\?\\UNC\\\\mach\\vol")
|
||||
(test (list (string->path "\\\\?\\") (string->path "c")) get-base "\\\\?\\c")
|
||||
(test (list (string->path "\\\\?\\UNC\\") (string->path "x")) get-base "\\\\?\\UNC\\x")
|
||||
(test (list (string->path "\\\\?\\") (string->path "UNC")) get-base "\\\\?\\UNC\\")
|
||||
(test (list #f (string->path "\\\\?\\UNC\\\\")) get-base "\\\\?\\UNC\\\\")
|
||||
(test (list #f (string->path "\\\\?\\xyz\\\\")) get-base "\\\\?\\xyz\\\\")
|
||||
(test (list (string->path "\\\\?\\c:\\a\\\\") (string->path "b")) get-base "\\\\?\\c:\\a\\\\\\b\\")
|
||||
(test (list #f (string->path "\\\\?\\c:\\a\\\\\\")) get-base "\\\\?\\c:\\a\\\\\\")
|
||||
(test (list (string->path "\\\\?\\UNC\\") (string->path "\\\\?\\REL\\\\x/y")) get-base "\\\\?\\UNC\\x/y")
|
||||
(test (list #f (string->path "\\\\?\\UNC\\x\\y")) get-base "\\\\?\\UNC\\x\\y")
|
||||
(test (list (string->path "\\\\?\\REL\\\\x\\y ") (string->path "z")) get-base "x/y /z")
|
||||
(test (list (string->path "\\\\?\\REL\\\\y ") (string->path "z")) get-base "x/../y /z")
|
||||
(test (list (string->path "\\\\?\\REL\\..\\\\y ") (string->path "z")) get-base "../y /z")
|
||||
(test (list (string->path "\\\\?\\c:\\y ") (string->path "z")) get-base "c:/y /z")
|
||||
(test (list (string->path "\\\\?\\c:\\y ") (string->path "z")) get-base "c:/../y /z")
|
||||
(test (list (string->path "../aux/") (string->path "z")) get-base "../aux/z")
|
||||
(test (list (string->path "../aux.m/") (string->path "z")) get-base "../aux.m/z")
|
||||
(test (list (string->path "..") (string->path "\\\\?\\REL\\\\aux.m")) get-base "../aux.m/")
|
||||
(test (list (string->path "c:/") (string->path "\\\\?\\REL\\\\aux.m")) get-base "c:/aux.m/")
|
||||
(test (list (string->path "c:/") (string->path "\\\\?\\REL\\\\aux.m.p")) get-base "c:/aux.m.p/")
|
||||
(test (list (string->path "c:/") (string->path "\\\\?\\REL\\\\aux:m")) get-base "c:/aux:m/")
|
||||
(test (list (string->path "..") (string->path "aux.m")) get-base "../aux.m")
|
||||
|
||||
;; simplify-path leaves literal . and .. alone:
|
||||
(test (string->path "\\\\?\\c:\\b\\.\\..\\a") simplify-path "\\\\?\\c:\\b\\.\\..\\a")
|
||||
(test (string->path "\\\\?\\c:\\B\\.\\..\\a") normal-case-path "\\\\?\\c:\\B\\.\\..\\a")
|
||||
(test (string->path "\\\\?\\UNC\\foo\\A") normal-case-path "\\\\?\\UNC\\foo\\A")
|
||||
|
||||
;; expand-path removes redundant backslashes, and
|
||||
(test (string->path "\\\\?\\\\UNC\\x\\y") expand-path "\\\\?\\\\UNC\\x\\y")
|
||||
(test (string->path "\\\\?\\c:\\") expand-path "\\\\?\\c:\\\\")
|
||||
|
||||
;; expand-path removes redundant backslashes, and
|
||||
;; simplify-path uses expand-path under Windows:
|
||||
(let ([go
|
||||
(lambda (expand-path)
|
||||
(test (string->path "c:\\") expand-path "c:")
|
||||
(test (string->path "C:/") expand-path "C://")
|
||||
(test (string->path "C:/a/") expand-path "C://a//")
|
||||
(test (string->path "\\\\?\\c:\\a\\.") expand-path "\\\\?\\c:\\\\a\\\\.")
|
||||
(test (string->path "\\\\?\\c:\\a\\\\") expand-path "\\\\?\\c:\\a\\\\")
|
||||
(test (string->path "\\\\?\\c:\\a\\.") expand-path "\\\\?\\c:\\a\\\\.")
|
||||
(test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path "\\\\?\\UNC\\\\a\\b\\.")
|
||||
(test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path "\\\\?\\UNC\\\\a\\b\\\\.")
|
||||
(test (string->path "\\\\?\\") expand-path "\\\\?\\\\"))])
|
||||
(go expand-path)
|
||||
(go simplify-path))
|
||||
|
||||
(test (bytes->path #"..") simplify-path "\\\\?\\REL\\..")
|
||||
(test (bytes->path #"..") simplify-path "\\\\?\\REL\\..\\")
|
||||
(test (bytes->path #"\\\\foo\\bar\\") expand-path "\\\\foo\\bar\\")
|
||||
(test (bytes->path #"\\\\foo\\bar") simplify-path "\\\\foo\\bar\\")
|
||||
(test (bytes->path #"\\\\foo\\bar") simplify-path "\\\\?\\UNC\\foo\\bar")
|
||||
(test (bytes->path #"\\\\foo\\bar") simplify-path "\\\\?\\UNC\\foo\\bar\\")
|
||||
(test (bytes->path #"\\\\?\\UNC\\foo\\bar\\..") simplify-path "\\\\?\\UNC\\foo\\bar\\..")
|
||||
(test (bytes->path #"\\\\?\\UNC\\foo\\bar\\..\\") simplify-path "\\\\?\\UNC\\foo\\bar\\..\\")
|
||||
(test (bytes->path #"a") simplify-path "\\\\?\\REL\\a")
|
||||
(test (bytes->path #"a") simplify-path "\\\\?\\REL\\\\a")
|
||||
(test (bytes->path #"a\\") simplify-path "\\\\?\\REL\\\\a\\")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\a/") simplify-path "\\\\?\\REL\\\\a/")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\..") simplify-path "\\\\?\\REL\\\\..")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\..\\") simplify-path "\\\\?\\REL\\\\..\\")
|
||||
(test (bytes->path #"a \\b") simplify-path "\\\\?\\REL\\\\a \\b")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\aux.bad\\b") simplify-path "\\\\?\\REL\\aux.bad\\b")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\a\\b ") simplify-path "\\\\?\\REL\\a\\b ")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\.\\b") simplify-path "\\\\?\\REL\\.\\b")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\.") simplify-path "\\\\?\\REL\\.")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\:\\b") simplify-path "\\\\?\\REL\\:\\b")
|
||||
(test (bytes->path #"\\\\?\\REL\\\\:") simplify-path "\\\\?\\REL\\:")
|
||||
(test (bytes->path #"\\\\?\\REL") simplify-path "\\\\?\\REL")
|
||||
(test (bytes->path #"C:\\a\\b") simplify-path "\\\\?\\C:\\a\\b")
|
||||
(test (bytes->path #"C:\\a") simplify-path "\\\\?\\C:\\a")
|
||||
(test (bytes->path #"\\\\?\\C:\\a ") simplify-path "\\\\?\\C:\\a ")
|
||||
(test (bytes->path #"\\\\?\\C:a\\b") simplify-path "\\\\?\\C:a\\b")
|
||||
(test (bytes->path #"\\\\?\\C:") simplify-path "\\\\?\\C:")
|
||||
(test (bytes->path #"\\\\?\\a\\y") simplify-path "\\\\?\\a\\y")
|
||||
(test (bytes->path #"\\\\?\\REL\\a\\y\\\\") simplify-path "\\\\?\\REL\\a\\y\\\\")
|
||||
(test (bytes->path #"\\\\?\\REL\\a\\\\\\y") simplify-path "\\\\?\\REL\\a\\\\\\y")
|
||||
|
||||
(let ([dir (build-path here "tmp78")])
|
||||
(unless (directory-exists? dir)
|
||||
(make-directory dir))
|
||||
|
|
@ -670,81 +489,340 @@
|
|||
|
||||
))
|
||||
|
||||
(let* ([bytes->path (lambda (p)
|
||||
(bytes->path p 'windows))]
|
||||
[string->path (if (eq? (system-path-convention-type) 'windows)
|
||||
string->path
|
||||
(lambda (p)
|
||||
(bytes->path (string->bytes/latin-1 p))))]
|
||||
[coerce (if (eq? (system-path-convention-type) 'windows)
|
||||
values
|
||||
string->path)]
|
||||
[get-base (lambda (s)
|
||||
(let-values ([(base name dir?) (split-path s)]) (list base name)))])
|
||||
(test (bytes->path #"c:\\a") path->complete-path (coerce "\\a") (coerce "c:"))
|
||||
(test (bytes->path #"\\\\foo\\bar\\a") path->complete-path (coerce "\\a") (coerce "\\\\foo\\bar\\a"))
|
||||
|
||||
;; Build path collapses .. and . in added parts and cleans up slashes and trailers:
|
||||
(test (string->path "\\\\?\\c:\\a\\b") build-path (coerce "\\\\?\\c:\\a") 'same (coerce "b"))
|
||||
(test (string->path "\\\\?\\c:\\a\\b") build-path (coerce "\\\\?\\c:\\a\\") 'same (coerce "b"))
|
||||
(test (string->path "\\\\?\\c:\\a\\.\\b") build-path (coerce "\\\\?\\c:\\a\\.") 'same (coerce "b"))
|
||||
(test (string->path "\\\\?\\c:\\a\\.\\b") build-path (coerce "\\\\?\\c:\\a\\.\\") 'same (coerce "b"))
|
||||
(test (string->path "\\\\?\\c:\\b") build-path (coerce "\\\\?\\c:\\a\\") 'up (coerce "b"))
|
||||
(test (string->path "\\\\?\\c:\\a\\b") build-path (coerce "\\\\?\\c:\\a\\.\\") 'up (coerce "b"))
|
||||
(test (string->path "\\\\?\\c:\\b") build-path (coerce "\\\\?\\c:\\a\\.\\") 'up 'up 'up (coerce "b"))
|
||||
(test (string->path "\\\\?\\c:\\a\\b\\c\\d\\f\\") build-path (coerce "\\\\?\\c:\\a") (coerce "b//c") (coerce "d//\\f///"))
|
||||
(test (string->path "\\\\?\\c:\\a\\foo") build-path (coerce "\\\\?\\c:\\a") (coerce "foo... "))
|
||||
|
||||
(test (string->path "\\\\?\\REL\\\\a") build-path (coerce ".") (coerce "\\\\?\\REL\\a"))
|
||||
(test (string->path "\\\\?\\REL\\\\a") build-path 'same (coerce "\\\\?\\REL\\a"))
|
||||
(test (string->path "\\\\?\\REL\\\\a\\") build-path (coerce "\\\\?\\REL\\a") 'same)
|
||||
(test (string->path ".") build-path (coerce "\\\\?\\REL\\a") 'up)
|
||||
(test (string->path "\\\\?\\REL\\\\apple") build-path (coerce "\\\\?\\REL\\a") 'up (coerce "apple"))
|
||||
(test (string->path ".") build-path (coerce "\\\\?\\REL\\a") 'up 'same)
|
||||
|
||||
(test (string->path "\\\\?\\REL\\..\\\\a") build-path 'up (coerce "\\\\?\\REL\\a"))
|
||||
(test (string->path "\\\\?\\REL\\..\\\\..") build-path 'up (coerce "\\\\?\\REL\\\\.."))
|
||||
(test (string->path "\\\\?\\REL\\..\\..") build-path 'up (coerce "\\\\?\\REL\\.."))
|
||||
(test (string->path "\\\\?\\REL\\..\\..") build-path (coerce "\\\\?\\REL\\..") 'up)
|
||||
(test (string->path "\\\\?\\REL\\..\\..\\..") build-path 'up (coerce "\\\\?\\REL\\..") 'up)
|
||||
(test (string->path "\\\\?\\REL\\..\\..\\\\..") build-path 'up (coerce "\\\\?\\REL\\..") (coerce "\\\\?\\REL\\\\.."))
|
||||
(test (string->path "\\\\?\\REL\\..\\..") build-path 'up (coerce "\\\\?\\REL\\..") (coerce "\\\\?\\REL\\\\..") 'up)
|
||||
(test (string->path "\\\\?\\REL\\\\..\\") build-path (coerce "\\\\?\\REL\\\\..") (coerce "\\\\?\\REL\\\\..") 'up)
|
||||
(test (string->path "\\\\?\\REL\\\\x\\") build-path (coerce "x/y") (coerce "\\\\?\\REL\\.."))
|
||||
(test (string->path "\\\\?\\c:\\x\\") build-path (coerce "c:x/y") (coerce "\\\\?\\REL\\.."))
|
||||
|
||||
(test-values (list (string->path "\\\\?\\REL\\..")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\REL\\..\\a"))))
|
||||
(test-values (list (string->path "\\\\?\\REL\\..")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\REL\\..\\\\a"))))
|
||||
(test-values (list (string->path "\\\\?\\REL\\b\\")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\REL\\b\\a"))))
|
||||
|
||||
(test (string->path "\\\\?\\RED\\\\a\\") build-path (coerce "\\\\?\\RED\\a") 'same)
|
||||
(test (string->path "\\") build-path (coerce "\\\\?\\RED\\a") 'up)
|
||||
(test (string->path "\\\\?\\RED\\\\apple") build-path (coerce "\\\\?\\RED\\a") 'up (coerce "apple"))
|
||||
(test (string->path "\\") build-path (coerce "\\\\?\\RED\\a") 'up 'same)
|
||||
|
||||
(test (string->path "\\") build-path (coerce "\\\\?\\RED\\..") 'up)
|
||||
(test (string->path "\\\\?\\RED\\\\..\\") build-path (coerce "\\\\?\\RED\\\\..") (coerce "\\\\?\\RED\\\\..") 'up)
|
||||
(test (string->path "\\\\?\\RED\\\\x\\y\\..") build-path (coerce "/x/y") (coerce "\\\\?\\RED\\.."))
|
||||
(test (string->path "\\\\?\\c:\\x\\y\\..") build-path (coerce "c:x/y") (coerce "\\\\?\\RED\\.."))
|
||||
|
||||
(test-values (list (string->path "\\\\?\\RED\\..\\")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\RED\\..\\a"))))
|
||||
(test-values (list (string->path "\\\\?\\RED\\..\\")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\RED\\..\\\\a"))))
|
||||
(test-values (list (string->path "\\\\?\\RED\\b\\")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\RED\\b\\a"))))
|
||||
(test-values (list (string->path "\\")
|
||||
(string->path "\\\\?\\REL\\\\..")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\RED\\.."))))
|
||||
(test-values (list (string->path "\\")
|
||||
(string->path "\\\\?\\REL\\\\a")
|
||||
#f)
|
||||
(lambda () (split-path (coerce "\\\\?\\RED\\a"))))
|
||||
|
||||
(test (string->path "\\\\?\\UNC\\f\\g") build-path (coerce "//f/g/h") (coerce "\\\\?\\REL\\.."))
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\") build-path (coerce "//f/g/h/i") (coerce "\\\\?\\REL\\.."))
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\..") build-path (coerce "//f/g/h") (coerce "\\\\?\\REL\\\\.."))
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\..") build-path (coerce "//f/g//h") (coerce "\\\\?\\REL\\\\.."))
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\i\\x") build-path (coerce "//f/g/h/../i") (coerce "\\\\?\\REL\\x"))
|
||||
(test (string->path "\\\\?\\UNC\\f\\g\\h\\i\\x") build-path (coerce "//f/g/../h/i") (coerce "\\\\?\\REL\\x"))
|
||||
|
||||
(let ([go (lambda (drive build-path simple)
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\"))
|
||||
build-path (coerce "/f/g/h") (coerce "\\\\?\\REL\\.."))
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\h\\x"))
|
||||
build-path (coerce "/f/g/h") (coerce "\\\\?\\REL\\x"))
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\h\\x"))
|
||||
build-path (coerce "//f//g/h") (coerce "\\\\?\\REL\\x"))
|
||||
(test (string->path (string-append "\\\\?\\" drive "f\\g\\h\\x"))
|
||||
build-path (coerce "/f//g////h") (coerce "\\\\?\\REL\\x"))
|
||||
(test (string->path simple)
|
||||
build-path (coerce "/f//g////h") (coerce "\\\\?\\REL\\..\\..\\..\\.."))
|
||||
(test (string->path (string-append "\\\\?\\" drive "?\\g\\h\\x"))
|
||||
build-path (coerce "//?/g/h") (coerce "\\\\?\\REL\\x")))])
|
||||
(go "RED\\\\" build-path "\\")
|
||||
(go "C:\\" (lambda args (path->complete-path (apply build-path args) (coerce "C:"))) "C:\\"))
|
||||
|
||||
;; Allow \\?\ as a drive to add an absolute path:
|
||||
(test (string->path "\\\\?\\c:\\b") build-path (coerce "\\\\?\\c:\\") (coerce "\\b"))
|
||||
(test (string->path "\\\\?\\c:\\b") build-path (coerce "\\\\?\\c:\\\\") (coerce "\\b"))
|
||||
(test (string->path "\\\\?\\c:\\b\\") build-path (coerce "\\\\?\\c:\\\\") (coerce "\\b\\"))
|
||||
(test (string->path "\\\\?\\UNC\\goo\\bar\\b") build-path (coerce "\\\\?\\UNC\\goo\\bar") (coerce "\\b"))
|
||||
(test (string->path "\\\\?\\\\b") build-path (coerce "\\\\?\\") (coerce "\\b"))
|
||||
(test (string->path "\\\\?\\\\b\\") build-path (coerce "\\\\?\\") (coerce "\\b\\"))
|
||||
(err/rt-test (build-path "\\\\?\\c:" (coerce "\\b")) exn:fail:contract?)
|
||||
|
||||
;; Don't allow path addition on bad \\?\ to change the root:
|
||||
(test (string->path "\\\\?\\\\c") build-path (coerce "\\\\?\\") (coerce "c"))
|
||||
(test (string->path "\\\\?\\\\UNC") build-path (coerce "\\\\?\\") (coerce "UNC"))
|
||||
(test (string->path "\\\\?\\\\UNC\\s\\y") build-path (coerce "\\\\?\\UNC") (coerce "s/y"))
|
||||
(test (string->path "\\\\?\\\\UNC\\s\\y") build-path (coerce "\\\\?\\UNC\\") (coerce "s/y"))
|
||||
(test (string->path "\\\\?\\\\REL\\s\\y") build-path (coerce "\\\\?\\REL") (coerce "s/y"))
|
||||
(test (string->path "\\\\?\\\\REL\\s\\y") build-path (coerce "\\\\?\\REL\\") (coerce "s/y"))
|
||||
(test (string->path "\\\\?\\REL\\\\\\s\\y") build-path (coerce "\\\\?\\REL\\\\") (coerce "s/y"))
|
||||
(test (string->path "\\\\?\\REL\\x\\\\\\z") build-path (coerce "\\\\?\\REL\\x\\\\") (coerce "z"))
|
||||
(test (string->path "/apple\\x") build-path (coerce "//apple") (coerce "x"))
|
||||
(test (string->path "\\\\?") build-path (coerce "\\\\") (coerce "?"))
|
||||
(test (string->path "\\?\\") build-path (coerce "\\\\") (coerce "?\\"))
|
||||
(test (string->path "\\?\\a") build-path (coerce "\\\\") (coerce "?") (coerce "a"))
|
||||
(test (string->path "\\?\\a") build-path (coerce "\\\\?") (coerce "a"))
|
||||
(test (string->path "\\?\\a\\") build-path (coerce "\\\\?") (coerce "a\\"))
|
||||
(test (string->path "\\\\?\\\\c:") build-path (coerce "\\\\?\\") (coerce "\\\\?\\REL\\c:"))
|
||||
(test (string->path "\\\\?\\\\c:\\") build-path (coerce "\\\\?\\") (coerce "\\\\?\\REL\\c:\\"))
|
||||
(test (string->path "\\\\?\\\\c:\\a") build-path (coerce "\\\\?\\") (coerce "\\\\?\\REL\\c:\\a"))
|
||||
(test (string->path "\\\\?\\\\REL\\b") build-path (coerce "\\\\?\\") (coerce "\\\\?\\REL\\REL\\b"))
|
||||
(test (string->path "\\\\?\\\\host\\vol\\a\\") build-path (coerce "\\\\?\\") (coerce "\\\\?\\REL\\\\host\\vol\\a\\"))
|
||||
|
||||
;; UNC paths can't have "?" for machine or "/" in machine part:
|
||||
(test (list (string->path "/?/") (string->path "x")) get-base (coerce "//?/x"))
|
||||
(test (list (string->path "\\\\?\\UNC\\a/b\\") (string->path "x")) get-base (coerce "\\\\?\\UNC\\a/b\\x"))
|
||||
|
||||
;; Split path must treat \\?\ part as a root:
|
||||
(test (list (string->path "\\\\?\\c:\\") (string->path "a")) get-base (coerce "\\\\?\\c:\\a"))
|
||||
(test (list (string->path "\\\\?\\") (string->path "\\\\?\\REL\\\\c:")) get-base (coerce "\\\\?\\c:"))
|
||||
(test (list #f (string->path "\\\\?\\c:\\")) get-base (coerce "\\\\?\\c:\\"))
|
||||
(test (list #f (string->path "\\\\?\\c:\\\\")) get-base (coerce "\\\\?\\c:\\\\"))
|
||||
(test (list (string->path "\\\\?\\c:\\") (string->path "a")) get-base (coerce "\\\\?\\c:\\\\a"))
|
||||
(test (list #f (string->path "\\\\?\\UNC\\mach\\vol")) get-base (coerce "\\\\?\\UNC\\mach\\vol"))
|
||||
(test (list #f (string->path "\\\\?\\UNC\\mach\\\\vol")) get-base (coerce "\\\\?\\UNC\\mach\\\\vol"))
|
||||
(test (list #f (string->path "\\\\?\\UNC\\\\mach\\vol")) get-base (coerce "\\\\?\\UNC\\\\mach\\vol"))
|
||||
(test (list (string->path "\\\\?\\") (string->path "c")) get-base (coerce "\\\\?\\c"))
|
||||
(test (list (string->path "\\\\?\\UNC\\") (string->path "x")) get-base (coerce "\\\\?\\UNC\\x"))
|
||||
(test (list (string->path "\\\\?\\") (string->path "UNC")) get-base (coerce "\\\\?\\UNC\\"))
|
||||
(test (list #f (string->path "\\\\?\\UNC\\\\")) get-base (coerce "\\\\?\\UNC\\\\"))
|
||||
(test (list #f (string->path "\\\\?\\xyz\\\\")) get-base (coerce "\\\\?\\xyz\\\\"))
|
||||
(test (list (string->path "\\\\?\\c:\\a\\\\") (string->path "b")) get-base (coerce "\\\\?\\c:\\a\\\\\\b\\"))
|
||||
(test (list #f (string->path "\\\\?\\c:\\a\\\\\\")) get-base (coerce "\\\\?\\c:\\a\\\\\\"))
|
||||
(test (list (string->path "\\\\?\\UNC\\") (string->path "\\\\?\\REL\\\\x/y")) get-base (coerce "\\\\?\\UNC\\x/y"))
|
||||
(test (list #f (string->path "\\\\?\\UNC\\x\\y")) get-base (coerce "\\\\?\\UNC\\x\\y"))
|
||||
(test (list (string->path "\\\\?\\REL\\\\x\\y ") (string->path "z")) get-base (coerce "x/y /z"))
|
||||
(test (list (string->path "\\\\?\\REL\\\\y ") (string->path "z")) get-base (coerce "x/../y /z"))
|
||||
(test (list (string->path "\\\\?\\REL\\..\\\\y ") (string->path "z")) get-base (coerce "../y /z"))
|
||||
(test (list (string->path "\\\\?\\c:\\y ") (string->path "z")) get-base (coerce "c:/y /z"))
|
||||
(test (list (string->path "\\\\?\\c:\\y ") (string->path "z")) get-base (coerce "c:/../y /z"))
|
||||
(test (list (string->path "../aux/") (string->path "z")) get-base (coerce "../aux/z"))
|
||||
(test (list (string->path "../aux.m/") (string->path "z")) get-base (coerce "../aux.m/z"))
|
||||
(test (list (string->path "..") (string->path "\\\\?\\REL\\\\aux.m")) get-base (coerce "../aux.m/"))
|
||||
(test (list (string->path "c:/") (string->path "\\\\?\\REL\\\\aux.m")) get-base (coerce "c:/aux.m/"))
|
||||
(test (list (string->path "c:/") (string->path "\\\\?\\REL\\\\aux.m.p")) get-base (coerce "c:/aux.m.p/"))
|
||||
(test (list (string->path "c:/") (string->path "\\\\?\\REL\\\\aux:m")) get-base (coerce "c:/aux:m/"))
|
||||
(test (list (string->path "..") (string->path "aux.m")) get-base (coerce "../aux.m"))
|
||||
|
||||
;; simplify-path leaves literal . and .. alone:
|
||||
(test (string->path "\\\\?\\c:\\b\\.\\..\\a") simplify-path (coerce "\\\\?\\c:\\b\\.\\..\\a") #f)
|
||||
(test (string->path "\\\\?\\c:\\B\\.\\..\\a") normal-case-path (coerce "\\\\?\\c:\\B\\.\\..\\a"))
|
||||
(test (string->path "\\\\?\\UNC\\foo\\A") normal-case-path (coerce "\\\\?\\UNC\\foo\\A"))
|
||||
(test (string->path "\\\\?\\RED\\..\\..") normal-case-path (coerce "\\\\?\\RED\\..\\.."))
|
||||
|
||||
;; expand-path removes redundant backslashes
|
||||
(when (eq? 'windows (system-type))
|
||||
(test (string->path "\\\\?\\\\UNC\\x\\y") expand-path (coerce "\\\\?\\\\UNC\\x\\y"))
|
||||
(test (string->path "\\\\?\\c:\\") expand-path (coerce "\\\\?\\c:\\\\")))
|
||||
|
||||
;; expand-path removes redundant backslashes, and
|
||||
;; simplify-path uses expand-path under Windows:
|
||||
(let ([go
|
||||
(lambda (expand-path)
|
||||
(test (string->path "c:\\") expand-path (coerce "c:"))
|
||||
(test (string->path "C:/") expand-path (coerce "C://"))
|
||||
(test (string->path "C:/a/") expand-path (coerce "C://a//"))
|
||||
(test (string->path "\\\\?\\c:\\a\\.") expand-path (coerce "\\\\?\\c:\\\\a\\\\."))
|
||||
(test (string->path "\\\\?\\c:\\a\\\\") expand-path (coerce "\\\\?\\c:\\a\\\\"))
|
||||
(test (string->path "\\\\?\\c:\\a\\.") expand-path (coerce "\\\\?\\c:\\a\\\\."))
|
||||
(test (string->path "\\\\?\\\\c:") expand-path (coerce "\\\\?\\c:"))
|
||||
(test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path (coerce "\\\\?\\UNC\\\\a\\b\\."))
|
||||
(test (string->path "\\\\?\\UNC\\a\\b\\.") expand-path (coerce "\\\\?\\UNC\\\\a\\b\\\\."))
|
||||
(test (string->path "\\\\?\\RED\\\\..") expand-path (coerce "\\\\?\\RED\\.."))
|
||||
(test (string->path "\\\\?\\") expand-path (coerce "\\\\?\\\\")))])
|
||||
(when (eq? 'windows (system-type))
|
||||
(go expand-path)
|
||||
(go simplify-path))
|
||||
(go (lambda (p) (simplify-path p #f))))
|
||||
|
||||
(test (bytes->path #"..") simplify-path (coerce "\\\\?\\REL\\..") #F)
|
||||
(test (bytes->path #"..") simplify-path (coerce "\\\\?\\REL\\..\\") #F)
|
||||
(when (eq? 'windows (system-type))
|
||||
(test (bytes->path #"\\\\foo\\bar\\") expand-path (coerce "\\\\foo\\bar\\")))
|
||||
(test (bytes->path #"\\\\foo\\bar") simplify-path (coerce "\\\\foo\\bar\\") #f)
|
||||
(test (bytes->path #"\\\\foo\\bar") simplify-path (coerce "\\\\?\\UNC\\foo\\bar") #f)
|
||||
(test (bytes->path #"\\\\foo\\bar") simplify-path (coerce "\\\\?\\UNC\\foo\\bar\\") #f)
|
||||
(test (bytes->path #"\\\\?\\UNC\\foo\\bar\\..") simplify-path (coerce "\\\\?\\UNC\\foo\\bar\\..") #f)
|
||||
(test (bytes->path #"\\\\?\\UNC\\foo\\bar\\..\\") simplify-path (coerce "\\\\?\\UNC\\foo\\bar\\..\\") #f)
|
||||
(test (bytes->path #"a") simplify-path (coerce "\\\\?\\REL\\a") #f)
|
||||
(test (bytes->path #"a") simplify-path (coerce "\\\\?\\REL\\\\a") #f)
|
||||
(test (bytes->path #"a\\") simplify-path (coerce "\\\\?\\REL\\\\a\\") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\a/") simplify-path (coerce "\\\\?\\REL\\\\a/") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\..") simplify-path (coerce "\\\\?\\REL\\\\..") #F)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\..\\") simplify-path (coerce "\\\\?\\REL\\\\..\\") #F)
|
||||
(test (bytes->path #"a \\b") simplify-path (coerce "\\\\?\\REL\\\\a \\b") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\aux.bad\\b") simplify-path (coerce "\\\\?\\REL\\aux.bad\\b") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\a\\b ") simplify-path (coerce "\\\\?\\REL\\a\\b ") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\.\\b") simplify-path (coerce "\\\\?\\REL\\.\\b") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\.") simplify-path (coerce "\\\\?\\REL\\.") #F)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\:\\b") simplify-path (coerce "\\\\?\\REL\\:\\b") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\\\:") simplify-path (coerce "\\\\?\\REL\\:") #F)
|
||||
(test (bytes->path #"\\\\?\\\\REL") simplify-path (coerce "\\\\?\\REL") #F)
|
||||
(test (bytes->path #"\\\\?\\\\REL") simplify-path (coerce "\\\\?\\\\REL") #F)
|
||||
(test (bytes->path #"C:\\a\\b") simplify-path (coerce "\\\\?\\C:\\a\\b") #f)
|
||||
(test (bytes->path #"C:\\a") simplify-path (coerce "\\\\?\\C:\\a") #f)
|
||||
(test (bytes->path #"\\\\?\\C:\\a ") simplify-path (coerce "\\\\?\\C:\\a ") #f)
|
||||
(test (bytes->path #"\\\\?\\\\C:a\\b") simplify-path (coerce "\\\\?\\C:a\\b") #f)
|
||||
(test (bytes->path #"\\\\?\\\\C:a\\b") simplify-path (coerce "\\\\?\\\\C:a\\b") #f)
|
||||
(test (bytes->path #"\\\\?\\\\C:") simplify-path (coerce "\\\\?\\C:") #f)
|
||||
(test (bytes->path #"\\\\?\\\\C:") simplify-path (coerce "\\\\?\\\\C:") #f)
|
||||
(test (bytes->path #"\\\\?\\\\a\\y") simplify-path (coerce "\\\\?\\a\\y") #f)
|
||||
(test (bytes->path #"\\\\?\\\\a\\y") simplify-path (coerce "\\\\?\\\\a\\y") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\a\\y\\\\") simplify-path (coerce "\\\\?\\REL\\a\\y\\\\") #f)
|
||||
(test (bytes->path #"\\\\?\\REL\\a\\\\\\y") simplify-path (coerce "\\\\?\\REL\\a\\\\\\y") #f)
|
||||
(test (bytes->path #"\\a") simplify-path (coerce "\\\\?\\RED\\a") #f)
|
||||
(test (bytes->path #"\\a") simplify-path (coerce "\\\\?\\RED\\\\a") #f)
|
||||
(test (bytes->path #"\\a\\b") simplify-path (coerce "\\\\?\\RED\\\\a\\\\b") #f))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ~ paths and other subtleties in Unix
|
||||
|
||||
(test (and (memq (system-type) '(unix macosx)) #t) absolute-path? "~")
|
||||
(when (absolute-path? "~")
|
||||
(test #t relative-path? "./~")
|
||||
(test (bytes->path #"./~") bytes->path-element #"~")
|
||||
(test #"~" path-element->bytes (bytes->path #"./~"))
|
||||
(test #"~" path-element->bytes (bytes->path #"./~/"))
|
||||
(test #"a" path-element->bytes (bytes->path #"a////////////"))
|
||||
(test (bytes->path #"./~me") bytes->path-element #"~me")
|
||||
(test #"~me" path-element->bytes (bytes->path #"./~me"))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"x/y")))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"x/~me")))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"/me")))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"/")))
|
||||
(err/rt-test (bytes->path-element #"./~"))
|
||||
(err/rt-test (bytes->path-element #"x/y"))
|
||||
(err/rt-test (bytes->path-element #"/x"))
|
||||
(err/rt-test (bytes->path-element #"/"))
|
||||
(test (bytes->path #"~") simplify-path (bytes->path #"~"))
|
||||
(test (bytes->path #"~") simplify-path (bytes->path #"~/"))
|
||||
(test (bytes->path #"~") simplify-path (bytes->path #"~/."))
|
||||
(test (bytes->path #"./~") simplify-path (bytes->path #"./~"))
|
||||
(test (bytes->path #"./~/") simplify-path (bytes->path #"./~/"))
|
||||
(test (bytes->path #"~/../..") simplify-path (bytes->path #"~/../..") #f)
|
||||
(test (bytes->path #"~/..") simplify-path (bytes->path #"~/../x/..") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"../x/..") #f)
|
||||
(test (bytes->path #"x/") simplify-path (bytes->path #"x/~/..") #f)
|
||||
(test (bytes->path #".") simplify-path (bytes->path #"./") #f)
|
||||
(test (bytes->path #".") simplify-path (bytes->path #".//") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"../") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"..//") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"..//./") #f)
|
||||
(test (bytes->path #"x/") path->directory-path (bytes->path #"x"))
|
||||
(test (bytes->path #"x/") path->directory-path (bytes->path #"x/"))
|
||||
(test (bytes->path #"x/.") path->directory-path (bytes->path #"x/."))
|
||||
(test (bytes->path #"x/./") path->directory-path (bytes->path #"x/./"))
|
||||
(test (bytes->path #"x/..") path->directory-path (bytes->path #"x/.."))
|
||||
(test (bytes->path #"x/../") path->directory-path (bytes->path #"x/../"))
|
||||
(test (bytes->path #".") path->directory-path (bytes->path #"."))
|
||||
(test (bytes->path #"./") path->directory-path (bytes->path #"./"))
|
||||
(test (bytes->path #"..") path->directory-path (bytes->path #".."))
|
||||
(test (bytes->path #"../") path->directory-path (bytes->path #"../"))
|
||||
(test (bytes->path #"~") path->directory-path (bytes->path #"~"))
|
||||
(test (bytes->path #"~me") path->directory-path (bytes->path #"~me"))
|
||||
(test (bytes->path #"~/") path->directory-path (bytes->path #"~/"))
|
||||
(test (bytes->path #"~me/") path->directory-path (bytes->path #"~me/"))
|
||||
(test (bytes->path #"./~/") path->directory-path (bytes->path #"./~"))
|
||||
(test-values (list #f (bytes->path #"~me") #t) (lambda () (split-path (bytes->path #"~me"))))
|
||||
(test-values (list #f (bytes->path #"~me") #t) (lambda () (split-path (bytes->path #"~me/"))))
|
||||
(test-values (list 'relative (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"./~me"))))
|
||||
(test-values (list 'relative (bytes->path #"./~me") #t) (lambda () (split-path (bytes->path #"./~me/"))))
|
||||
(test-values (list (bytes->path #"./.") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"././~me"))))
|
||||
(test-values (list 'relative (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #".//~me"))))
|
||||
(test-values (list (bytes->path #"y/x/") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"y/x/~me"))))
|
||||
(test-values (list (bytes->path #"y/x/") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"y//x//~me"))))
|
||||
(test-values (list (bytes->path #"y/x/.") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"y/x/./~me"))))
|
||||
(test-values (list (bytes->path #"x/") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"x/~me"))))
|
||||
(test-values (list (bytes->path #"x/") (bytes->path #"./~me") #t) (lambda () (split-path (bytes->path #"x/~me/"))))
|
||||
(test-values (list (bytes->path #"x/.") (bytes->path #"y") #f) (lambda () (split-path (bytes->path #"x/./y"))))
|
||||
(test-values (list (bytes->path #"x/..") (bytes->path #"y") #f) (lambda () (split-path (bytes->path #"x/../y"))))
|
||||
(test-values (list (bytes->path #"~me") (bytes->path #"y") #f) (lambda () (split-path (bytes->path #"~me/y"))))
|
||||
(test-values (list (bytes->path #"~me/y/") (bytes->path #"z") #f) (lambda () (split-path (bytes->path #"~me/y/z"))))
|
||||
(test (bytes->path #"/home/mflatt/~") build-path (bytes->path #"/home/mflatt") (bytes->path #"./~"))
|
||||
(test (bytes->path #"/home/mflatt/././~") build-path (bytes->path #"/home/mflatt") (bytes->path #"././~"))
|
||||
(test (bytes->path #"./~") build-path (bytes->path #"./~"))
|
||||
(let ([dir "tmp79"])
|
||||
(unless (directory-exists? dir)
|
||||
(make-directory dir))
|
||||
(close-output-port (open-output-file "tmp79/~me" 'replace))
|
||||
(test (list (bytes->path #"./~me")) directory-list dir)
|
||||
(delete-file (build-path "tmp79" (bytes->path #"./~me")))
|
||||
(delete-directory dir))
|
||||
(void))
|
||||
(test (and (memq (system-path-convention-type) '(unix)) #t) absolute-path? "~")
|
||||
(test #t absolute-path? (bytes->path #"~" 'unix))
|
||||
(test #f absolute-path? (bytes->path #"~" 'windows))
|
||||
|
||||
(define (test-~-paths kind)
|
||||
(let* ([use-fs? (eq? kind (system-path-convention-type))]
|
||||
[bytes->path (if use-fs?
|
||||
bytes->path
|
||||
(lambda (s) (bytes->path s kind)))]
|
||||
|
||||
[bytes->path-element (if use-fs?
|
||||
bytes->path-element
|
||||
(lambda (s) (bytes->path-element s kind)))])
|
||||
(test #t relative-path? (bytes->path #"./~"))
|
||||
(test (bytes->path #"./~") bytes->path-element #"~")
|
||||
(test #"~" path-element->bytes (bytes->path #"./~"))
|
||||
(test #"~" path-element->bytes (bytes->path #"./~/"))
|
||||
(test #"a" path-element->bytes (bytes->path #"a////////////"))
|
||||
(test (bytes->path #"./~me") bytes->path-element #"~me")
|
||||
(test #"~me" path-element->bytes (bytes->path #"./~me"))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"x/y")))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"x/~me")))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"/me")))
|
||||
(err/rt-test (path-element->bytes (bytes->path #"/")))
|
||||
(err/rt-test (bytes->path-element #"./~"))
|
||||
(err/rt-test (bytes->path-element #"x/y"))
|
||||
(err/rt-test (bytes->path-element #"/x"))
|
||||
(err/rt-test (bytes->path-element #"/"))
|
||||
(test (bytes->path #"~") simplify-path (bytes->path #"~") use-fs?)
|
||||
(test (bytes->path #"~") simplify-path (bytes->path #"~/") use-fs?)
|
||||
(test (bytes->path #"~") simplify-path (bytes->path #"~/.") use-fs?)
|
||||
(test (bytes->path #"./~") simplify-path (bytes->path #"./~") use-fs?)
|
||||
(test (bytes->path #"./~/") simplify-path (bytes->path #"./~/") use-fs?)
|
||||
(test (bytes->path #"~/../..") simplify-path (bytes->path #"~/../..") #f)
|
||||
(test (bytes->path #"~/..") simplify-path (bytes->path #"~/../x/..") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"../x/..") #f)
|
||||
(test (bytes->path #"x/") simplify-path (bytes->path #"x/~/..") #f)
|
||||
(test (bytes->path #".") simplify-path (bytes->path #"./") #f)
|
||||
(test (bytes->path #".") simplify-path (bytes->path #".//") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"../") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"..//") #f)
|
||||
(test (bytes->path #"..") simplify-path (bytes->path #"..//./") #f)
|
||||
(test (bytes->path #"x/") path->directory-path (bytes->path #"x"))
|
||||
(test (bytes->path #"x/") path->directory-path (bytes->path #"x/"))
|
||||
(test (bytes->path #"x/.") path->directory-path (bytes->path #"x/."))
|
||||
(test (bytes->path #"x/./") path->directory-path (bytes->path #"x/./"))
|
||||
(test (bytes->path #"x/..") path->directory-path (bytes->path #"x/.."))
|
||||
(test (bytes->path #"x/../") path->directory-path (bytes->path #"x/../"))
|
||||
(test (bytes->path #".") path->directory-path (bytes->path #"."))
|
||||
(test (bytes->path #"./") path->directory-path (bytes->path #"./"))
|
||||
(test (bytes->path #"..") path->directory-path (bytes->path #".."))
|
||||
(test (bytes->path #"../") path->directory-path (bytes->path #"../"))
|
||||
(test (bytes->path #"~") path->directory-path (bytes->path #"~"))
|
||||
(test (bytes->path #"~me") path->directory-path (bytes->path #"~me"))
|
||||
(test (bytes->path #"~/") path->directory-path (bytes->path #"~/"))
|
||||
(test (bytes->path #"~me/") path->directory-path (bytes->path #"~me/"))
|
||||
(test (bytes->path #"./~/") path->directory-path (bytes->path #"./~"))
|
||||
(test-values (list #f (bytes->path #"~me") #t) (lambda () (split-path (bytes->path #"~me"))))
|
||||
(test-values (list #f (bytes->path #"~me") #t) (lambda () (split-path (bytes->path #"~me/"))))
|
||||
(test-values (list 'relative (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"./~me"))))
|
||||
(test-values (list 'relative (bytes->path #"./~me") #t) (lambda () (split-path (bytes->path #"./~me/"))))
|
||||
(test-values (list (bytes->path #"./.") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"././~me"))))
|
||||
(test-values (list 'relative (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #".//~me"))))
|
||||
(test-values (list (bytes->path #"y/x/") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"y/x/~me"))))
|
||||
(test-values (list (bytes->path #"y/x/") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"y//x//~me"))))
|
||||
(test-values (list (bytes->path #"y/x/.") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"y/x/./~me"))))
|
||||
(test-values (list (bytes->path #"x/") (bytes->path #"./~me") #f) (lambda () (split-path (bytes->path #"x/~me"))))
|
||||
(test-values (list (bytes->path #"x/") (bytes->path #"./~me") #t) (lambda () (split-path (bytes->path #"x/~me/"))))
|
||||
(test-values (list (bytes->path #"x/.") (bytes->path #"y") #f) (lambda () (split-path (bytes->path #"x/./y"))))
|
||||
(test-values (list (bytes->path #"x/..") (bytes->path #"y") #f) (lambda () (split-path (bytes->path #"x/../y"))))
|
||||
(test-values (list (bytes->path #"~me") (bytes->path #"y") #f) (lambda () (split-path (bytes->path #"~me/y"))))
|
||||
(test-values (list (bytes->path #"~me/y/") (bytes->path #"z") #f) (lambda () (split-path (bytes->path #"~me/y/z"))))
|
||||
(test (bytes->path #"/home/mflatt/~") build-path (bytes->path #"/home/mflatt") (bytes->path #"./~"))
|
||||
(test (bytes->path #"/home/mflatt/././~") build-path (bytes->path #"/home/mflatt") (bytes->path #"././~"))
|
||||
(test (bytes->path #"./~") build-path (bytes->path #"./~"))
|
||||
(when use-fs?
|
||||
(let ([dir "tmp79"])
|
||||
(unless (directory-exists? dir)
|
||||
(make-directory dir))
|
||||
(close-output-port (open-output-file "tmp79/~me" 'replace))
|
||||
(test (list (bytes->path #"./~me")) directory-list dir)
|
||||
(delete-file (build-path "tmp79" (bytes->path #"./~me")))
|
||||
(delete-directory dir)))
|
||||
(void)))
|
||||
|
||||
(test-~-paths 'unix)
|
||||
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
(test p sync p)
|
||||
(test s sync s)
|
||||
(test #f sync/timeout 0 p)
|
||||
(thread (lambda () (sleep SYNC-SLEEP-DELAY) (semaphore-post s)))
|
||||
(thread (lambda () (sync (system-idle-evt)) (semaphore-post s)))
|
||||
(test p sync p)
|
||||
(test p sync p)
|
||||
(test s sync s)
|
||||
|
|
@ -34,7 +34,7 @@
|
|||
(test 7 channel-get ch)
|
||||
(test #f channel-try-get ch)
|
||||
(thread (lambda () (channel-put ch 9)))
|
||||
(sleep SYNC-SLEEP-DELAY)
|
||||
(sync (system-idle-evt))
|
||||
(test 9 channel-try-get ch)
|
||||
(test #f channel-try-get ch))
|
||||
|
||||
|
|
@ -50,19 +50,19 @@
|
|||
(let ([c (make-channel)]
|
||||
[v 'nope])
|
||||
(test #f sync/timeout 0 c)
|
||||
(thread (lambda () (sleep SYNC-SLEEP-DELAY) (set! v (channel-get c))))
|
||||
(thread (lambda () (sync (system-idle-evt)) (set! v (channel-get c))))
|
||||
(test (void) channel-put c 10)
|
||||
(sleep)
|
||||
(sync (system-idle-evt))
|
||||
(test 10 'thread-v v)
|
||||
(thread (lambda () (sleep SYNC-SLEEP-DELAY) (channel-put c 11)))
|
||||
(thread (lambda () (sync (system-idle-evt)) (channel-put c 11)))
|
||||
(test #f sync/timeout 0 c)
|
||||
(test 11 sync c)
|
||||
(let ([p (channel-put-evt c 45)])
|
||||
(thread (lambda () (sleep SYNC-SLEEP-DELAY) (set! v (sync c))))
|
||||
(thread (lambda () (sync (system-idle-evt)) (set! v (sync c))))
|
||||
(test #f sync/timeout 0 p)
|
||||
(test p sync p)
|
||||
(test #f sync/timeout 0 p)
|
||||
(sleep)
|
||||
(sync (system-idle-evt))
|
||||
(test 45 'thread-v v))
|
||||
;;;;; Make sure break/kill before action => break/kill only
|
||||
;; get:
|
||||
|
|
@ -70,11 +70,11 @@
|
|||
(let ([t (thread (lambda ()
|
||||
(set! v (channel-get c))))])
|
||||
(test #t thread-running? t)
|
||||
(sleep)
|
||||
(sync (system-idle-evt))
|
||||
(test #t thread-running? t)
|
||||
(test (void) break-thread t)
|
||||
(test #f sync/timeout 0 (channel-put-evt c 32))
|
||||
(sleep)
|
||||
(sync (system-idle-evt))
|
||||
(test #f thread-running? t)
|
||||
(test 45 'old-v v)))])
|
||||
(try break-thread)
|
||||
|
|
@ -83,18 +83,18 @@
|
|||
(let ([try (lambda (break-thread)
|
||||
(let ([t (thread (lambda () (channel-put c 17)))])
|
||||
(test #t thread-running? t)
|
||||
(sleep)
|
||||
(sync (system-idle-evt))
|
||||
(test #t thread-running? t)
|
||||
(test (void) break-thread t)
|
||||
(test #f sync/timeout 0 c)
|
||||
(sleep)
|
||||
(sync (system-idle-evt))
|
||||
(test #f thread-running? t)))])
|
||||
(try break-thread)
|
||||
(try kill-thread))
|
||||
;; put in main thread:
|
||||
(let ([t (current-thread)])
|
||||
(thread (lambda ()
|
||||
(sleep SYNC-SLEEP-DELAY)
|
||||
(sync (system-idle-evt))
|
||||
(break-thread t)
|
||||
(set! v (channel-get c)))))
|
||||
(test 77
|
||||
|
|
@ -108,7 +108,7 @@
|
|||
;; get in main thread:
|
||||
(let ([t (current-thread)])
|
||||
(thread (lambda ()
|
||||
(sleep SYNC-SLEEP-DELAY)
|
||||
(sync (system-idle-evt))
|
||||
(break-thread t)
|
||||
(channel-put c 66))))
|
||||
(test 99
|
||||
|
|
@ -215,8 +215,8 @@
|
|||
(make-semaphore) (make-semaphore) (make-semaphore) (make-semaphore)
|
||||
(let ([sema (make-semaphore 1)])
|
||||
(wrap-evt sema (lambda (x)
|
||||
(test sema values x)
|
||||
77)))))))
|
||||
(test sema values x)
|
||||
77)))))))
|
||||
|
||||
;; More alarms:
|
||||
(let ([make-delay
|
||||
|
|
@ -250,14 +250,14 @@
|
|||
(test 18 'sync
|
||||
(let ([n 17]
|
||||
[s (make-semaphore)])
|
||||
(thread (lambda () (sleep SYNC-SLEEP-DELAY) (semaphore-post s)))
|
||||
(thread (lambda () (sync (system-idle-evt)) (semaphore-post s)))
|
||||
(sync
|
||||
(wrap-evt
|
||||
s
|
||||
(lambda (sema) (set! n (add1 n)) n))
|
||||
(wrap-evt
|
||||
s
|
||||
(lambda (sema) (set! n (add1 n)) n)))))
|
||||
(wrap-evt
|
||||
s
|
||||
(lambda (sema) (set! n (add1 n)) n))
|
||||
(wrap-evt
|
||||
s
|
||||
(lambda (sema) (set! n (add1 n)) n)))))
|
||||
|
||||
(let ([c (make-channel)])
|
||||
(thread (lambda () (channel-put c 76)))
|
||||
|
|
@ -666,12 +666,12 @@
|
|||
(test t sync/timeout 0 s)
|
||||
(test t sync/timeout 0 r)
|
||||
(let* ([s (thread-suspend-evt t)])
|
||||
(thread (lambda () (sleep SYNC-SLEEP-DELAY) (thread-suspend t)))
|
||||
(thread (lambda () (sync (system-idle-evt)) (thread-suspend t)))
|
||||
(test #f sync/timeout 0 s)
|
||||
(test t sync s)
|
||||
(let* ([r (thread-resume-evt t)]
|
||||
[d (thread-dead-evt t)])
|
||||
(thread (lambda () (sleep SYNC-SLEEP-DELAY) (thread-resume t)))
|
||||
(thread (lambda () (sync (system-idle-evt)) (thread-resume t)))
|
||||
(test #f sync/timeout 0 r)
|
||||
(test t sync r)
|
||||
|
||||
|
|
|
|||
|
|
@ -221,7 +221,7 @@
|
|||
(let* ([hit? #f]
|
||||
[t (parameterize ([current-custodian (make-custodian)])
|
||||
(thread (lambda () (thunk) (set! hit? #t))))])
|
||||
(sleep SLEEP-TIME)
|
||||
(sync (system-idle-evt))
|
||||
(begin0 (test block? 'nondeterministic-block-test (not hit?))
|
||||
(kill-thread t)))))
|
||||
|
||||
|
|
@ -265,7 +265,7 @@
|
|||
(with-handlers ([exn:break? (lambda (x) (semaphore-post s2))])
|
||||
(semaphore-wait (make-semaphore 0)))))])
|
||||
(semaphore-wait s1)
|
||||
(sleep SLEEP-TIME)
|
||||
(sync (system-idle-evt))
|
||||
(break-thread t)
|
||||
(semaphore-wait s2)
|
||||
'ok))
|
||||
|
|
@ -370,7 +370,7 @@
|
|||
(lambda ()
|
||||
(semaphore-wait s)
|
||||
(set! l (cons who l)))))]
|
||||
[pause (lambda () (sleep 0.01))])
|
||||
[pause (lambda () (sync (system-idle-evt)))])
|
||||
(wait 0) (pause)
|
||||
(wait 1) (pause)
|
||||
(wait 2)
|
||||
|
|
@ -701,7 +701,7 @@
|
|||
(let ([t2 (thread (lambda ()
|
||||
(thread-suspend (current-thread))
|
||||
(set! v 99)))])
|
||||
(sleep SLEEP-TIME)
|
||||
(sync (system-idle-evt))
|
||||
(test #f thread-running? t2)
|
||||
(test #f thread-dead? t2)
|
||||
(thread-resume t2)
|
||||
|
|
@ -722,7 +722,7 @@
|
|||
(test #f thread-dead? t2)
|
||||
(test #f thread-running? t2)
|
||||
(semaphore-post s)
|
||||
(sleep SLEEP-TIME)
|
||||
(sync (system-idle-evt))
|
||||
(test 17 values v)
|
||||
(thread-resume t2)
|
||||
(thread-wait t2)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user