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

add optional 'sep' argument to path-add-extension

Browse Source 
New optional argument to 'path-add-extension',
 a byte string to replace for the '.' in the argument path.
This commit is contained in:
Ben Greenman 2017-03-25 19:40:34 -04:00
parent e22a5da06c
commit 2cbd44d64d
3 changed files with 37 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
pkgs/racket-doc/scribblings/reference/paths.scrbl
View File

@ -561,22 +561,25 @@ extension separator.
@defproc[(path-add-extension [path (or/c path-string? path-for-some-system?)]
[ext (or/c string? bytes?)])
[ext (or/c string? bytes?)]
[sep (or/c string? bytes?) #"_"])
path-for-some-system?]{
Similar to @racket[path-replace-extension], but any existing extension on
@racket[path] is preserved by replacing the @litchar{.} before the extension
with @litchar{_}, and then the @racket[ext] is added
with @racket[sep], and then the @racket[ext] is added
to the end.
@examples[
(path-add-extension "x/y.ss" #".rkt")
(path-add-extension "x/y" #".rkt")
(path-add-extension "x/y.tar.gz" #".rkt")
(path-add-extension "x/y.tar.gz" #".rkt" #".")
(path-add-extension "x/.racketrc" #".rkt")
]
@history[#:added "6.5.0.3"]}
@history[#:changed "6.8.0.2" @elem{Added the @racket[sep] optional argument.}
#:added "6.5.0.3"]}
@defproc[(path-replace-suffix [path (or/c path-string? path-for-some-system?)]

5
pkgs/racket-test-core/tests/racket/path.rktl
View File

@ -44,6 +44,11 @@
(test (string->path ".zo.y") path-add-extension ".zo" #".y")
(test (string->path ".tar_gz.y") path-add-extension ".tar.gz" ".y")
(test (string->path ".tar_gz.y") path-add-extension ".tar.gz" #".y")
(test (string->some-system-path "p/x.tar.gz" 'unix)
path-add-extension (string->some-system-path "p/x.tar" 'unix) ".gz" #".")
(test (string->some-system-path "p/x.tar.gz" 'windows)
path-add-extension (string->some-system-path "p/x.tar" 'windows) ".gz" ".")
(err/rt-test (path-add-extension "x" ".zip" #f))
(test (string->path ".y") path-replace-suffix ".zo" ".y")
(test (string->path ".y") path-replace-suffix ".zo" #".y")

38
racket/collects/racket/private/path.rkt
View File

@ -46,27 +46,38 @@
;; ----------------------------------------
(define-values (check-extension-call)
(lambda (s sfx who)
(unless (or (path-for-some-system? s)
(path-string? s))
(raise-argument-error who "(or/c path-for-some-system? path-string?)" 0 s sfx))
(unless (or (string? sfx) (bytes? sfx))
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
(lambda (s sfx who sep trust-sep?)
(let-values ([(err-msg err-index)
(cond
[(not (or (path-for-some-system? s) (path-string? s)))
(values "(or/c path-for-some-system? path-string?)" 0)]
[(not (or (string? sfx) (bytes? sfx)))
(values "(or/c string? bytes?)" 1)]
[(not (or trust-sep? (string? sep) (bytes? sep)))
(values "(or/c string? bytes?)" 2)]
[else
(values #f #f)])])
(when err-msg
(if trust-sep?
(raise-argument-error who err-msg err-index s sfx)
(raise-argument-error who err-msg err-index s sfx sep))))
(let-values ([(base name dir?) (split-path s)])
(when (not base)
(raise-mismatch-error who "cannot add an extension to a root path: " s))
(values base name))))
(define-values (path-adjust-extension)
(lambda (name sep rest-bytes s sfx)
(let-values ([(base name) (check-extension-call s sfx name)])
(lambda (name sep rest-bytes s sfx trust-sep?)
(let-values ([(base name) (check-extension-call s sfx name sep trust-sep?)])
(-define bs (path-element->bytes name))
(-define finish
(lambda (i sep i2)
(bytes->path-element
(bytes-append
(subbytes bs 0 i)
sep
(if (string? sep)
(string->bytes/locale sep (char->integer #\?))
sep)
(rest-bytes bs i2)
(if (string? sfx)
(string->bytes/locale sfx (char->integer #\?))
@ -90,11 +101,14 @@
(define-values (path-replace-extension)
(lambda (s sfx)
(path-adjust-extension 'path-replace-extension #"" (lambda (bs i) #"") s sfx)))
(path-adjust-extension 'path-replace-extension #"" (lambda (bs i) #"") s sfx #t)))
(define-values (path-add-extension)
(lambda (s sfx)
(path-adjust-extension 'path-add-extension #"_" subbytes s sfx)))
(case-lambda
[(s sfx)
(path-adjust-extension 'path-add-extension #"_" subbytes s sfx #t)]
[(s sfx sep)
(path-adjust-extension 'path-add-extension sep subbytes s sfx #f)]))
;; ----------------------------------------