From 4180d67e342a35cdbd3b85b36a1827d849656531 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Jan 2009 13:52:26 +0000 Subject: [PATCH] make scheme/path fuctions work on paths for any playform svn: r13064 --- collects/scheme/path.ss | 29 +++++---- collects/scribblings/gui/color-class.scrbl | 8 ++- collects/scribblings/reference/paths.scrbl | 19 +++--- collects/tests/mzscheme/mzlib-tests.ss | 1 + collects/tests/mzscheme/pathlib.ss | 69 ++++++++++++++++++++++ 5 files changed, 103 insertions(+), 23 deletions(-) create mode 100644 collects/tests/mzscheme/pathlib.ss diff --git a/collects/scheme/path.ss b/collects/scheme/path.ss index d093181713..26ec3e2180 100644 --- a/collects/scheme/path.ss +++ b/collects/scheme/path.ss @@ -113,18 +113,19 @@ (let loop ([path orig-path][rest '()]) (let-values ([(base name dir?) (split-path path)]) (when simple? - (when (or (and base (not (path? base))) - (not (path? name))) + (when (or (and base (not (path-for-some-system? base))) + (not (path-for-some-system? name))) (raise-type-error who - "path in simple form (absolute, complete, and with no same- or up-directory indicators)" + "path (for ay platform) in simple form (absolute, complete, and with no same- or up-directory indicators)" orig-path))) - (if (path? base) + (if (path-for-some-system? base) (loop base (cons name rest)) (cons name rest))))) (define (explode-path orig-path) - (unless (path-string? orig-path) - (raise-type-error 'explode-path "path or string" orig-path)) + (unless (or (path-string? orig-path) + (path-for-some-system? orig-path)) + (raise-type-error 'explode-path "path (for any platform) or string" orig-path)) (do-explode-path 'explode-path orig-path #f)) ;; Arguments must be in simple form @@ -143,20 +144,22 @@ filename))) (define (file-name who name) - (unless (path-string? name) - (raise-type-error who "path or string" name)) + (unless (or (path-string? name) + (path-for-some-system? name)) + (raise-type-error who "path (for any platform) or string" name)) (let-values ([(base file dir?) (split-path name)]) - (and (not dir?) (path? file) file))) + (and (not dir?) (path-for-some-system? file) file))) (define (file-name-from-path name) (file-name 'file-name-from-path name)) (define (path-only name) - (unless (path-string? name) - (raise-type-error 'path-only "path or string" name)) + (unless (or (path-string? name) + (path-for-some-system? name)) + (raise-type-error 'path-only "path (for any platform) or string" name)) (let-values ([(base file dir?) (split-path name)]) - (cond [dir? name] - [(path? base) base] + (cond [dir? (if (string? name) (string->path name) name)] + [(path-for-some-system? base) base] [else #f]))) ;; name can be any string; we just look for a dot diff --git a/collects/scribblings/gui/color-class.scrbl b/collects/scribblings/gui/color-class.scrbl index 118d78f130..07eb8a6582 100644 --- a/collects/scribblings/gui/color-class.scrbl +++ b/collects/scribblings/gui/color-class.scrbl @@ -13,14 +13,16 @@ See @scheme[color-database<%>] for information about obtaining a color object using a color name. -@defconstructor*/make[(([red (integer-in 0 255)] +@defconstructor*/make[(() + ([red (integer-in 0 255)] [green (integer-in 0 255)] [blue (integer-in 0 255)]) ([color-name string?]))]{ Creates a new color with the given RGB values, or matching the given - color name (using ``black'' if the name is not recognized). See - @scheme[color-database<%>] for more information on color names. + color name (using ``black'' if no color is given or if the name is + not recognized). See @scheme[color-database<%>] for more information + on color names. } diff --git a/collects/scribblings/reference/paths.scrbl b/collects/scribblings/reference/paths.scrbl index e5dc1f5f1d..b221a2840b 100644 --- a/collects/scribblings/reference/paths.scrbl +++ b/collects/scribblings/reference/paths.scrbl @@ -494,21 +494,22 @@ to the end.} @note-lib[scheme/path] -@defproc[(explode-path [path path-string?]) - (listof (or/c path? 'up 'same))]{ +@defproc[(explode-path [path (or/c path-string? path-for-some-system?)]) + (listof (or/c path-for-some-system? 'up 'same))]{ Returns the list of path element that constitute @scheme[path]. If @scheme[path] is simplified in the sense of @scheme[simple-form-path], then the result is always a list of paths, and the first element of the list is a root.} -@defproc[(file-name-from-path [path path-string?]) (or/c path? #f)]{ +@defproc[(file-name-from-path [path (or/c path-string? path-for-some-system?)]) + (or/c path-for-some-system? #f)]{ Returns the last element of @scheme[path]. If @scheme[path] syntactically a directory path (see @scheme[split-path]), then then result is @scheme[#f].} -@defproc[(filename-extension [path path-string?]) +@defproc[(filename-extension [path (or/c path-string? path-for-some-system?)]) (or/c bytes? #f)]{ Returns a byte string that is the extension part of the filename in @@ -516,7 +517,9 @@ Returns a byte string that is the extension part of the filename in syntactically a directory (see @scheme[split-path]) or if the path has no extension, @scheme[#f] is returned.} -@defproc[(find-relative-path [base path-string?][path path-string?]) path?]{ +@defproc[(find-relative-path [base (or/c path-string? path-for-some-system?)] + [path (or/c path-string? path-for-some-system?)]) + path-for-some-system?]{ Finds a relative pathname with respect to @scheme[basepath] that names the same file or directory as @scheme[path]. Both @scheme[basepath] @@ -544,10 +547,12 @@ An error is signaled by @scheme[normalize-path] if the input path contains an embedded path for a non-existent directory, or if an infinite cycle of soft links is detected.} -@defproc[(path-only [path path-string?]) (or/c path? #f)]{ +@defproc[(path-only [path (or/c path-string? path-for-some-system?)]) + path-for-some-system?]{ If @scheme[path] is a filename, the file's path is returned. If -@scheme[path] is syntactically a directory, @scheme[#f] is returned.} +@scheme[path] is syntactically a directory, @scheme[path] is returned +(as a path, if it was a string).} @defproc[(simple-form-path [path path-string?]) path?]{ diff --git a/collects/tests/mzscheme/mzlib-tests.ss b/collects/tests/mzscheme/mzlib-tests.ss index 6003409b7e..6e89d5435f 100644 --- a/collects/tests/mzscheme/mzlib-tests.ss +++ b/collects/tests/mzscheme/mzlib-tests.ss @@ -10,6 +10,7 @@ (load-in-sandbox "async-channel.ss") (load-in-sandbox "restart.ss") (load-in-sandbox "string-mzlib.ss") +(load-in-sandbox "pathlib.ss") (load-in-sandbox "filelib.ss") (load-in-sandbox "portlib.ss") (load-in-sandbox "threadlib.ss") diff --git a/collects/tests/mzscheme/pathlib.ss b/collects/tests/mzscheme/pathlib.ss new file mode 100644 index 0000000000..262d83a444 --- /dev/null +++ b/collects/tests/mzscheme/pathlib.ss @@ -0,0 +1,69 @@ + +(load-relative "loadtest.ss") + +(Section 'path) + +(require scheme/path) + +(define (rtest f args result) + (test result f args)) + +;; ---------------------------------------- + +(rtest explode-path "a/b" (list (string->path "a") + (string->path "b"))) +(rtest explode-path "a/../b" (list (string->path "a") + 'up + (string->path "b"))) +(rtest explode-path "./a/b" (list 'same + (string->path "a") + (string->path "b"))) +(rtest explode-path (bytes->path #"./a/b" 'unix) (list 'same + (bytes->path #"a" 'unix) + (bytes->path #"b" 'unix))) +(rtest explode-path (bytes->path #"./a\\b" 'windows) (list 'same + (bytes->path #"a" 'windows) + (bytes->path #"b" 'windows))) + +;; ---------------------------------------- + +(rtest file-name-from-path "a/" #f) +(rtest file-name-from-path "a/b" (string->path "b")) +(rtest file-name-from-path (bytes->path #"a/b" 'unix) (bytes->path #"b" 'unix)) +(rtest file-name-from-path (bytes->path #"a\\b" 'windows) (bytes->path #"b" 'windows)) + +;; ---------------------------------------- + +(rtest filename-extension "a" #f) +(rtest filename-extension "a.sls" #"sls") +(rtest filename-extension (bytes->path #"b/a.sls" 'unix) #"sls") +(rtest filename-extension (bytes->path #"b\\a.sls" 'windows) #"sls") + +;; ---------------------------------------- + +(test (string->path "a") find-relative-path (path->complete-path "b") (path->complete-path "b/a")) +(test (string->path "../../b/a") find-relative-path (path->complete-path "c/b") (path->complete-path "b/a")) +(test (bytes->path #"a" 'unix) find-relative-path (bytes->path #"/r/b" 'unix) (bytes->path #"/r/b/a" 'unix)) +(test (bytes->path #"a" 'windows) find-relative-path (bytes->path #"c:/r/b" 'windows) (bytes->path #"c:/r/b/a" 'windows)) + +;; ---------------------------------------- + +;; normalize-path needs tests + +;; ---------------------------------------- + +(rtest path-only "a/b" (string->path "a/")) +(rtest path-only "a/b/" (string->path "a/b/")) +(rtest path-only "a/.." (string->path "a/..")) +(rtest path-only (bytes->path #"a/z" 'unix) (bytes->path #"a/" 'unix)) +(rtest path-only (bytes->path #"a/z/" 'unix) (bytes->path #"a/z/" 'unix)) +(rtest path-only (bytes->path #"a/z" 'windows) (bytes->path #"a/" 'windows)) +(rtest path-only (bytes->path #"a/z/" 'windows) (bytes->path #"a/z/" 'windows)) + +;; ---------------------------------------- + +;; simple-form-path needs tests + +;; ---------------------------------------- + +(report-errs)