1 ! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors combinators combinators.short-circuit
4 continuations destructors fry io io.backend io.encodings.binary
5 io.files io.pathnames kernel namespaces sequences system vocabs ;
8 : set-current-directory ( path -- )
9 absolute-path current-directory set ;
11 : with-directory ( path quot -- )
12 [ absolute-path current-directory ] dip with-variable ; inline
14 : with-resource-directory ( quot -- )
15 [ "resource:" ] dip with-directory ; inline
17 ! Creating directories
18 HOOK: make-directory io-backend ( path -- )
20 DEFER: make-parent-directories
22 : make-directories ( path -- )
23 normalize-path trim-tail-separators dup {
29 make-parent-directories
33 : make-parent-directories ( filename -- filename )
34 dup parent-directory make-directories ;
37 TUPLE: directory-entry name type ;
39 C: <directory-entry> directory-entry
41 HOOK: (directory-entries) os ( path -- seq )
43 : directory-entries ( path -- seq )
46 [ name>> { "." ".." } member? ] reject ;
48 : directory-files ( path -- seq )
49 directory-entries [ name>> ] map! ;
51 : with-directory-entries ( path quot -- )
52 '[ "" directory-entries @ ] with-directory ; inline
54 : with-directory-files ( path quot -- )
55 '[ "" directory-files @ ] with-directory ; inline
57 : qualified-directory-entries ( path -- seq )
59 dup directory-entries [ [ append-path ] change-name ] with map! ;
61 : qualified-directory-files ( path -- seq )
63 dup directory-files [ append-path ] with map! ;
65 : with-qualified-directory-files ( path quot -- )
66 '[ "" qualified-directory-files @ ] with-directory ; inline
68 : with-qualified-directory-entries ( path quot -- )
69 '[ "" qualified-directory-entries @ ] with-directory ; inline
72 HOOK: touch-file io-backend ( path -- )
75 HOOK: delete-file io-backend ( path -- )
77 HOOK: delete-directory io-backend ( path -- )
79 : ?delete-file ( path -- )
80 '[ _ delete-file ] ignore-errors ;
82 : to-directory ( from to -- from to' )
83 over file-name append-path ;
85 ! Moving and renaming files
86 HOOK: move-file io-backend ( from to -- )
88 : move-file-into ( from to -- )
89 to-directory move-file ;
91 : move-files-into ( files to -- )
92 '[ _ move-file-into ] each ;
95 HOOK: copy-file io-backend ( from to -- )
98 make-parent-directories binary <file-writer> [
99 swap binary <file-reader> [
104 : copy-file-into ( from to -- )
105 to-directory copy-file ;
107 : copy-files-into ( files to -- )
108 '[ _ copy-file-into ] each ;
111 { [ os unix? ] [ "io.directories.unix" require ] }
112 { [ os windows? ] [ "io.directories.windows" require ] }