From cccf1fb97892bb02ab9f3ad0ac27626ac3150b5e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 4 Sep 2005 00:01:13 +0000 Subject: [PATCH] mred unicode tests, mzscheme windows path tests svn: r761 --- collects/tests/mred/item.ss | 34 +++--- collects/tests/mzscheme/path.ss | 201 +++++++++++++++++++++++++++++++- 2 files changed, 217 insertions(+), 18 deletions(-) diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss index b678d22051..4686a07913 100644 --- a/collects/tests/mred/item.ss +++ b/collects/tests/mred/item.ss @@ -360,7 +360,7 @@ (send p stretchable-height stretchy?) (let () - (define l (make-object (trace-mixin message%) "Messag&\uE9" p null ($ font))) ; \uE9 is e with ' + (define l (make-object (trace-mixin message%) "L\u03B9&st" #;"Messag&\u03A3" p null ($ font))) ; \u03A3 is eta (define il (make-object (trace-mixin message%) return-bmp p null ($ font))) (add-testers "Message" l) @@ -372,7 +372,7 @@ (values l il)))) (define b (make-object (trace-mixin button%) - "H\uE9&llo" ip ; \uE9 is e with ' + "H\u03A3&llo" ip ; \u03A3 is eta (lambda (b e) (send b enable #f) (sleep/yield 5) @@ -384,20 +384,20 @@ ; (define ib2 (make-object button% return-bmp ip void)) (define lb (make-object (trace-mixin list-box%) - (if null-label? #f "L\uED&st") ; \uED is i with ' - '("Appl\uE9" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") ; \uE9 is e with ' + (if null-label? #f "L\u03B9&st") ; \u03B9 is iota + '("Appl\u03A3" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") ; \u03A3 is eta ip void (add-label-direction label-h? '(single)) (if alt-inits? 2 #f) (or font view-control-font) ($ font))) - (define cb (make-object (trace-mixin check-box%) "C&h\u00E9ck" ip void null alt-inits? ($ font))) ; \uE9 is e with ' + (define cb (make-object (trace-mixin check-box%) "C&h\u03A3ck" ip void null alt-inits? ($ font))) ; \u03A3 is eta (define icb (make-object (trace-mixin check-box%) mred-bmp ip void null alt-inits? ($ font))) (define rb (make-object (trace-mixin radio-box%) - (if null-label? #f "R&ad\uEDo") ; \uED is i with ' - '("F\uEDrst" "Dos" "T&rio") + (if null-label? #f "R&ad\u03B9o") ; \u03B9 is iota + '("F\u03B9rst" "Dos" "T&rio") ip void (add-label-direction label-h? @@ -420,15 +420,15 @@ ($ font))) (define ch (make-object (trace-mixin choice%) - (if null-label? #f "Ch&o\u00EDce") ; \uED is i with ' - '("Alpha" "Beta" "Gamma" "Delta & R\uE9st") ; \uE9 is e with ' + (if null-label? #f "Ch&o\u03B9ce") ; \u03B9 is iota + '("Alpha" "Beta" "Gamma" "Delta & R\u03A3st") ; \u03A3 is eta ip void (add-label-direction label-h? null) (if alt-inits? 3 0) ($ font))) (define txt (make-object (trace-mixin text-field%) - (if null-label? #f "T\uE9&xt") ; \uE9 is e with ' + (if null-label? #f "T\u03A3&xt") ; \u03A3 is eta ip void "initial & starting" (add-label-direction label-h? '(single)) @@ -548,7 +548,7 @@ (define f (make-frame (if use-dialogs? active-dialog% active-frame%) - "T\uE9ster")) ; \uE9 is e with ' + "T\u03A3ster")) ; \u03A3 is eta (define hp (make-object horizontal-panel% f)) @@ -645,7 +645,7 @@ (make-object combo-field% "Greet:" '("Hola" "Ni Hao") ip2 void "hello" null ($ font))) (define sh (make-object slider% - (if null-label? #f "H S&lid\uE9r") 0 10 ip2 + (if null-label? #f "H S&lid\u03A3r") 0 10 ip2 (lambda (s e) (send gh set-value (* 10 (send sh get-value)))) 5 @@ -655,7 +655,7 @@ ($ font))) (define sv (make-object slider% - (if null-label? #f "V Sl&id\uE9r") 0 10 ip2 + (if null-label? #f "V Sl&id\u03A3r") 0 10 ip2 (lambda (s e) (send gv set-value (* 10 (send sv get-value)))) 5 @@ -665,14 +665,14 @@ ($ font))) (define gh (make-object gauge% - (if null-label? #f "H G&aug\uE9") 100 ip2 + (if null-label? #f "H G&aug\u03A3") 100 ip2 (add-label-direction label-h? '(horizontal)) ($ font))) (define gv (make-object gauge% - (if null-label? #f "V Ga&ug\uE9") 100 ip2 + (if null-label? #f "V Ga&ug\u03A3") 100 ip2 (add-label-direction label-h? '(vertical)) @@ -688,12 +688,12 @@ ($ font))) (define tab (make-object tab-panel% - '("Appl\uE9" "B&anana") ip2 void + '("Appl\u03A3" "B&anana") ip2 void null ($ font))) (define grp (make-object group-box-panel% - "Group\uE9" ip2 + "Group\u03A3" ip2 null (or font small-control-font))) (make-object button% "OK" tab void) diff --git a/collects/tests/mzscheme/path.ss b/collects/tests/mzscheme/path.ss index edc360e6c1..bcc042fa84 100644 --- a/collects/tests/mzscheme/path.ss +++ b/collects/tests/mzscheme/path.ss @@ -3,6 +3,8 @@ (SECTION 'PATH) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (define (make-/tf p exn?) (lambda args (with-handlers ([exn? (lambda (x) #f)] @@ -374,7 +376,11 @@ (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'up "b")) (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'same 'up "b" 'same 'same)) (test-path (full-path "a" "b") simplify-path (build-path 'same "noexistsdir" 'same 'up "a" 'same "b" 'same 'same))) -(arity-test simplify-path 1 1) +(test (build-path "x" "y") simplify-path (build-path "x" "z" 'up "y") #f) +(test (build-path 'up "x" "y") simplify-path (build-path 'up "x" "z" 'up "y") #f) +(test (build-path 'up "x" "y") simplify-path (build-path 'up 'same "x" "z" 'up "y") #f) +(test (build-path 'up 'up "x" "y") simplify-path (build-path 'up 'same 'up "x" "z" 'up "y") #f) +(arity-test simplify-path 1 2) (arity-test expand-path 1 1) (arity-test resolve-path 1 1) @@ -396,4 +402,197 @@ ; normal-case-path now checks for pathness: (err/rt-test (normal-case-path (string #\a #\nul #\b))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; \\?\ paths in Windows + +(when (eq? 'windows (system-type)) + (let ([here (regexp-replace + #rx"[\\]$" + (string-append + "\\\\?\\" + (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) + (test #t directory-exists? (string-append here "\\")) ; trailing separator is ok for dir + (test #f directory-exists? (string-append here "\\\\")) ; extra isn't ok + + (let ([dir (ormap (lambda (f) + (and (directory-exists? f) f)) + (directory-list))]) + (when dir + (map (lambda (sep) + (let ([dirstr (string-append here sep (path->string dir))]) + (test #t directory-exists? dirstr) + (test #t directory-exists? (string-append dirstr "\\")) + (test #f directory-exists? (string-append dirstr "\\\\")) + (test (file-or-directory-modify-seconds dir) file-or-directory-modify-seconds dirstr) + )) + '("\\" "\\\\")))) + + (let ([file (ormap (lambda (f) + (and (file-exists? f) f)) + (directory-list))]) + (when file + (map (lambda (sep) + (let ([filestr (string-append here sep (path->string file))]) + (test #t file-exists? filestr) + (test #f file-exists? (string-append filestr "\\")) + (test (file-or-directory-modify-seconds file) file-or-directory-modify-seconds filestr) + )) + '("\\" "\\\\")))) + + ;; Check drive and path->complete-path: + (parameterize ([current-directory "\\\\?\\"]) + (test (string->path "\\\\?\\") current-drive) + (test (string->path "\\\\?\\\\a") path->complete-path "\\a") + ) + (parameterize ([current-directory "\\\\?\\x\\y\\"]) + (test (string->path "\\\\?\\") current-drive) + (test (string->path "\\\\?\\\\a") path->complete-path "\\a") + ) + (parameterize ([current-directory "\\\\?\\d:\\foo"]) + (test (string->path "\\\\?\\d:\\") current-drive) + (test (string->path "\\\\?\\d:\\a") path->complete-path "\\a") + ) + (parameterize ([current-directory "\\\\?\\UNC\\foo\\bar\\baz"]) + (test (string->path "\\\\?\\UNC\\foo\\bar") current-drive) + (test (string->path "\\\\?\\UNC\\foo\\bar\\a") path->complete-path "\\a") + ) + (parameterize ([current-directory "\\\\?\\REL\\"]) + (test (string->path "\\\\?\\") current-drive) + (test (string->path "\\\\?\\\\a") path->complete-path "\\a") + ) + (parameterize ([current-directory "\\\\?\\REL\\a\\\\"]) + (test (string->path "\\\\?\\REL\\a\\\\") current-drive) + (test (string->path "\\\\?\\REL\\a\\\\\\a") path->complete-path "\\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\\x") build-path "x/y" "\\\\?\\REL\\..") + (test (string->path "\\\\?\\c:x\\") build-path "c:x/y" "\\\\?\\REL\\..") + + (test (string->path "\\\\?\\UNC\\f\\g\\") 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\\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") + + ;; 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") + + ;; 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 #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 (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 path 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: + (test (string->path "\\\\?\\c:\\a\\b") expand-path "\\\\?\\c:\\\\a\\\\b") + (test (string->path "\\\\?\\c:\\") expand-path "\\\\?\\c:\\\\") + (test (string->path "\\\\?\\c:\\a\\\\") expand-path "\\\\?\\c:\\a\\\\") + (test (string->path "\\\\?\\c:\\a\\b") expand-path "\\\\?\\c:\\a\\\\b") + + ;; watch out for simplification that changes root: + (test (string->path "\\\\?\\\\UNC\\a\\b\\c") expand-path "\\\\?\\UNC\\\\a\\b\\c") + (test (string->path "\\\\?\\\\UNC\\a\\b\\c") expand-path "\\\\?\\UNC\\\\a\\b\\\\c") + + (let ([dir (build-path here "tmp78")]) + (unless (directory-exists? dir) + (make-directory dir)) + (close-output-port (open-output-file (build-path here "tmp78" "\\\\?\\REL\\aux") + 'replace)) + (test (list (string->path "\\\\?\\REL\\\\aux")) directory-list dir) + (delete-file (build-path here "tmp78" "\\\\?\\REL\\aux")) + (delete-directory dir)) + + )) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + (report-errs)