Adding create-directory*.

This commit is contained in:
Alex Shinn 2013-08-31 20:16:01 +09:00
parent d198557c8b
commit 080cdef849
2 changed files with 18 additions and 2 deletions

View file

@ -2,6 +2,22 @@
;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved. ;; Copyright (c) 2009-2012 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt ;; BSD-style license: http://synthcode.com/license.txt
;;> Creates the directory \var{dir}, including any parent directories
;;> as needed. Returns \scheme{#t} on success and \scheme{#f} on
;;> failure.
(define (create-directory* dir . o)
(let ((mode (if (pair? o) (car o) #o755)))
(or (create-directory dir mode)
(let ((slash
(string-find-right dir #\/ 0 (string-skip-right dir #\/))))
(and (> slash 0)
(let ((parent (substring-cursor dir 0 slash)))
(and (not (equal? parent dir))
(not (file-exists? parent))
(create-directory* parent mode)
(create-directory dir mode))))))))
;;> The fundamental directory iterator. Applies \var{kons} to ;;> The fundamental directory iterator. Applies \var{kons} to
;;> each filename in directory \var{dir} and the result of the ;;> each filename in directory \var{dir} and the result of the
;;> previous application, beginning with \var{knil}. With ;;> previous application, beginning with \var{knil}. With

View file

@ -11,7 +11,7 @@
delete-file link-file symbolic-link-file rename-file delete-file link-file symbolic-link-file rename-file
directory-files directory-fold directory-fold-tree directory-files directory-fold directory-fold-tree
delete-file-hierarchy delete-directory delete-file-hierarchy delete-directory
create-directory create-directory create-directory*
current-directory change-directory with-directory current-directory change-directory with-directory
open open-pipe make-fifo open open-pipe make-fifo
file-status file-status
@ -30,7 +30,7 @@
open/create open/exclusive open/truncate open/create open/exclusive open/truncate
open/append open/non-block open/append open/non-block
is-a-tty?) is-a-tty?)
(import (chibi)) (import (chibi) (chibi string))
(include-shared "filesystem") (include-shared "filesystem")
(include "filesystem.scm")) (include "filesystem.scm"))