From 5e5cbfe18b1ad9a4b304c188db2221829f5738e9 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Tue, 26 May 2009 01:14:11 +0300 Subject: [PATCH] - Added make-directory* (like make-directory, but builds the whole directory structure recursively) - Added split-file-name (takes a string, returns two values: the substring before the final "/" and the string after it). - Fixed a minor bug in file-directory?, file-exists?, etc. that were failing on OS X if part of the path given was not a directory. E.g., if /tmp/foo is a regular file, (file-directory? "/tmp/foo/bar") was raising an exception instead of returning #f. --- scheme/ikarus.posix.ss | 94 +++++++++++++++++++++++++++++++----------- scheme/last-revision | 2 +- scheme/makefile.ss | 2 + 3 files changed, 73 insertions(+), 25 deletions(-) diff --git a/scheme/ikarus.posix.ss b/scheme/ikarus.posix.ss index 7bffbf8..411090e 100644 --- a/scheme/ikarus.posix.ss +++ b/scheme/ikarus.posix.ss @@ -18,25 +18,26 @@ (export posix-fork fork waitpid system file-exists? delete-file - nanosleep getenv setenv unsetenv env environ file-ctime - file-mtime file-real-path current-directory file-regular? - file-directory? file-readable? file-writable? file-executable? - file-size rename-file file-symbolic-link? make-symbolic-link - make-hard-link directory-list make-directory delete-directory - change-mode kill strerror wstatus-pid wstatus-exit-status - wstatus-received-signal) + nanosleep getenv setenv unsetenv env environ split-file-name + file-ctime file-mtime file-real-path current-directory + file-regular? file-directory? file-readable? file-writable? + file-executable? file-size rename-file file-symbolic-link? + make-symbolic-link make-hard-link directory-list make-directory + make-directory* delete-directory change-mode kill strerror + wstatus-pid wstatus-exit-status wstatus-received-signal) (import (rnrs bytevectors) (except (ikarus) nanosleep posix-fork fork waitpid system file-exists? - delete-file getenv setenv unsetenv env environ file-ctime - file-mtime file-real-path current-directory file-regular? - file-directory? file-readable? file-writable? + delete-file getenv setenv unsetenv env environ split-file-name + file-ctime file-mtime file-real-path current-directory + file-regular? file-directory? file-readable? file-writable? file-executable? file-size rename-file file-symbolic-link? make-symbolic-link make-hard-link directory-list - make-directory delete-directory change-mode kill strerror - wstatus-pid wstatus-exit-status wstatus-received-signal)) + make-directory make-directory* delete-directory change-mode + kill strerror wstatus-pid wstatus-exit-status + wstatus-received-signal)) (define posix-fork (lambda () @@ -153,8 +154,29 @@ [(2) 'directory] [(3) 'symlink] [(-45) #f] ;; from ikarus-errno.c: ENOENT -- path does not exist + [(-57) #f] ;; from ikarus-errno.c: ENOTDIR -- path does not exist [else (raise/strerror who r path)])))) + (define (split-file-name str) + (define who 'split-file-name) + (define path-sep #\/) + (define (find-last c str) + (let f ([i (string-length str)]) + (if (fx=? i 0) + #f + (let ([i (fx- i 1)]) + (if (char=? (string-ref str i) c) + i + (f i)))))) + (unless (string? str) (die who "not a string" str)) + (cond + [(find-last path-sep str) => + (lambda (i) + (values + (substring str 0 i) + (let ([i (fx+ i 1)]) + (substring str i (string-length str) ))))] + [else (values "" str)])) (define access (lambda (path how who) @@ -218,7 +240,6 @@ (unless (eq? v #t) (raise/strerror who v x))))) - (define rename-file (lambda (src dst) (define who 'rename-file) @@ -242,19 +263,44 @@ (raise/strerror who r path) (map utf8->string (reverse r)))))) + (define ($make-directory path mode who) + (unless (string? path) + (die who "not a string" path)) + (unless (fixnum? mode) + (die who "not a fixnum" mode)) + (let ([r (foreign-call "ikrt_mkdir" (string->utf8 path) mode)]) + (unless (eq? r #t) + (raise/strerror who r path)))) + + (define default-dir-mode #o755) + (define make-directory (case-lambda - [(path) (make-directory path #o755)] - [(path mode) - (define who 'make-directory) - (unless (string? path) - (die who "not a string" path)) - (unless (fixnum? mode) - (die who "not a fixnum" mode)) - (let ([r (foreign-call "ikrt_mkdir" (string->utf8 path) mode)]) - (unless (eq? r #t) - (raise/strerror who r path)))])) - + [(path) (make-directory path default-dir-mode)] + [(path mode) ($make-directory path mode 'make-directory)])) + + (module (make-directory*) + (define who 'make-directory*) + (define (mkdir* dirname0 mode) + (unless (string? dirname0) + (die who "not a string" dirname0)) + (let f ([dirname dirname0]) + (cond + [(file-exists? dirname) + (unless (file-directory? dirname) + (die who + (format "path component ~a is not a directory" dirname) + dirname0))] + [else + (let-values ([(base suffix) (split-file-name dirname)]) + (unless (string=? base "") (f base)) + (unless (string=? suffix "") + ($make-directory dirname mode who)))]))) + (define make-directory* + (case-lambda + [(name) (mkdir* name default-dir-mode)] + [(name mode) (mkdir* name mode)]))) + (define delete-directory (case-lambda [(path) (delete-directory path #f)] diff --git a/scheme/last-revision b/scheme/last-revision index c670086..50d09fb 100644 --- a/scheme/last-revision +++ b/scheme/last-revision @@ -1 +1 @@ -1790 +1791 diff --git a/scheme/makefile.ss b/scheme/makefile.ss index ec16c2d..cf8fabe 100755 --- a/scheme/makefile.ss +++ b/scheme/makefile.ss @@ -1278,6 +1278,7 @@ [current-directory i] [directory-list i] [make-directory i] + [make-directory* i] [delete-directory i] [directory-stream? i] [open-directory-stream i] @@ -1290,6 +1291,7 @@ [file-mtime i] [file-size i] [file-real-path i] + [split-file-name i] [fork i] [define-record-type i r rs] [fields i r rs]