From 2cbd44d64d815faeb939421cf448fbe2ae7635d0 Mon Sep 17 00:00:00 2001
From: Ben Greenman <benjaminlgreenman@gmail.com>
Date: Sat, 25 Mar 2017 19:40:34 -0400
Subject: [PATCH] add optional 'sep' argument to path-add-extension

New optional argument to 'path-add-extension',
 a byte string to replace for the '.' in the argument path.
---
 .../scribblings/reference/paths.scrbl         |  9 +++--
 pkgs/racket-test-core/tests/racket/path.rktl  |  5 +++
 racket/collects/racket/private/path.rkt       | 38 +++++++++++++------
 3 files changed, 37 insertions(+), 15 deletions(-)

diff --git a/pkgs/racket-doc/scribblings/reference/paths.scrbl b/pkgs/racket-doc/scribblings/reference/paths.scrbl
index 6165995e87..f3d3f9c70e 100644
--- a/pkgs/racket-doc/scribblings/reference/paths.scrbl
+++ b/pkgs/racket-doc/scribblings/reference/paths.scrbl
@@ -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?)]
diff --git a/pkgs/racket-test-core/tests/racket/path.rktl b/pkgs/racket-test-core/tests/racket/path.rktl
index 3e1d74c544..0ebbcf08ee 100644
--- a/pkgs/racket-test-core/tests/racket/path.rktl
+++ b/pkgs/racket-test-core/tests/racket/path.rktl
@@ -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")
diff --git a/racket/collects/racket/private/path.rkt b/racket/collects/racket/private/path.rkt
index c17f2cb058..810b901589 100644
--- a/racket/collects/racket/private/path.rkt
+++ b/racket/collects/racket/private/path.rkt
@@ -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)]))
 
   ;; ----------------------------------------