suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

make scheme/path fuctions work on paths for any playform

Browse Source 
svn: r13064
This commit is contained in:
Matthew Flatt 2009-01-11 13:52:26 +00:00
parent 3c22ff982b
commit 4180d67e34
5 changed files with 103 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/scheme/path.ss
View File

@ -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

8
collects/scribblings/gui/color-class.scrbl
View File

@ -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.
}

19
collects/scribblings/reference/paths.scrbl
View File

@ -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?]{

1
collects/tests/mzscheme/mzlib-tests.ss
View File

@ -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")

69
collects/tests/mzscheme/pathlib.ss Normal file
View File

@ -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)