From 92917264826970644cf4944657ec8e9628be79e7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 27 Oct 2014 13:56:38 -0600 Subject: [PATCH] racket/file: add `make-parent-directory*` Also, clarify behavior of `make-directory*` in the case of a relative path when the current directory does not exist. --- .../scribblings/reference/filesystem.scrbl | 22 +++++++++++- .../racket-test/tests/racket/file.rktl | 36 +++++++++++++++++++ racket/collects/pkg/private/path.rkt | 4 --- racket/collects/racket/file.rkt | 13 +++++++ racket/src/racket/src/schvers.h | 4 +-- 5 files changed, 72 insertions(+), 7 deletions(-) diff --git a/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl b/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl index d1e0ef2663..83b6946c2b 100644 --- a/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl +++ b/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl @@ -1058,7 +1058,27 @@ paths disappear during the scan, then an exception is raised.} Creates directory specified by @racket[path], creating intermediate directories as necessary, and never failing if @racket[path] exists -already.} +already. + +If @racket[path] is a relative path and the current directory does not +exist, then @racket[make-directory*] will not create the current +directory, because it considers only explicit elements of +@racket[path].} + + +@defproc[(make-parent-directory* [path path-string?]) void?]{ + +Creates the parent directory of the path specified by @racket[path], +creating intermediate directories as necessary, and never failing if +an ancestor of @racket[path] exists already. + +If @racket[path] is a filesystem root or a relative path with a single +path element, then no directory is created. Like +@racket[make-directory*], if @racket[path] is a relative path and the +current directory does not exist, then @racket[make-parent-directory*] +will not create it. + +@history[#:added "6.1.1.3"]} @defproc[(make-temporary-file [template string? "rkttmp~a"] diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl b/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl index eb09e403ab..e8d19d5d4b 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl +++ b/pkgs/racket-pkgs/racket-test/tests/racket/file.rktl @@ -1710,6 +1710,42 @@ (values f #t))))) (delete-directory/files tmp-dir)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Test `make[-parent]-directory` + +(let () + (define tmp (find-system-path 'temp-dir)) + (define (check build-z-dir-path pick-directory) + (define made (make-temporary-file "check-make-~a" 'directory)) + (define z-dir (build-z-dir-path made "x" "y")) + (define z (build-path z-dir "z")) + (parameterize ([current-directory (pick-directory made)]) + (test #f directory-exists? z-dir) + (test #f file-exists? z) + (make-parent-directory* z) + (test #t directory-exists? z-dir) + (make-parent-directory* z) + (delete-directory/files z-dir) + (test #f directory-exists? z-dir) + (make-directory* z) + (test #t directory-exists? z-dir) + (test #t directory-exists? z) + (make-directory* z) + (make-parent-directory* z)) + (delete-directory/files made)) + (check build-path (lambda (made) (current-directory))) + (check (lambda args (apply build-path (cdr args))) values) + (check (lambda args (apply build-path 'same (cdr args))) values)) + +;; Check on a current directory that does not exist: +(let () + (define made (make-temporary-file "check-make-~a" 'directory)) + (parameterize ([current-directory (build-path made "nonesuch")]) + (make-parent-directory* "z") + (test #f directory-exists? (current-directory)) + (err/rt-test (make-directory* "z") exn:fail:filesystem?)) + (delete-directory/files made)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check that `in-directory' fails properly on filesystem errors diff --git a/racket/collects/pkg/private/path.rkt b/racket/collects/pkg/private/path.rkt index af12c2ce67..f6d0a6ab47 100644 --- a/racket/collects/pkg/private/path.rkt +++ b/racket/collects/pkg/private/path.rkt @@ -6,10 +6,6 @@ (provide (all-defined-out)) -(define (make-parent-directory* p) - (define parent (path-only p)) - (make-directory* parent)) - (define (path->bytes* pkg) (cond [(path? pkg) diff --git a/racket/collects/racket/file.rkt b/racket/collects/racket/file.rkt index 984c7c528f..6be16cbe3e 100644 --- a/racket/collects/racket/file.rkt +++ b/racket/collects/racket/file.rkt @@ -7,6 +7,7 @@ (provide delete-directory/files copy-directory/files make-directory* + make-parent-directory* make-temporary-file get-preference @@ -94,6 +95,8 @@ [else (raise-not-a-file-or-directory 'copy-directory/files src)]))) (define (make-directory* dir) + (unless (path-string? dir) + (raise-argument-error 'make-directory* "path-string?" dir)) (let-values ([(base name dir?) (split-path dir)]) (when (and (path? base) (not (directory-exists? base))) @@ -102,6 +105,16 @@ (with-handlers ([exn:fail:filesystem:exists? void]) (make-directory dir))))) +(define (make-parent-directory* p) + (unless (path-string? p) + (raise-argument-error 'make-parent-directory* "path-string?" p)) + (define-values (base name dir?) (split-path p)) + (cond + [(path? base) (make-directory* base)] + [else + ;; Do nothing with an immediately relative path or a root directory + (void)])) + (define-syntax (make-temporary-file stx) (with-syntax ([app (datum->syntax stx #'#%app stx)]) (syntax-case stx () diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index d899f80186..43e666b536 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.1.1.2" +#define MZSCHEME_VERSION "6.1.1.3" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)