1 ! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: io.backend io.files.private io hashtables kernel
4 kernel.private math memory namespaces sequences strings assocs
5 arrays definitions system combinators splitting sbufs
6 continuations destructors io.encodings io.encodings.binary init
10 HOOK: (file-reader) io-backend ( path -- stream )
12 HOOK: (file-writer) io-backend ( path -- stream )
14 HOOK: (file-appender) io-backend ( path -- stream )
16 : <file-reader> ( path encoding -- stream )
17 swap normalize-path (file-reader) swap <decoder> ;
19 : <file-writer> ( path encoding -- stream )
20 swap normalize-path (file-writer) swap <encoder> ;
22 : <file-appender> ( path encoding -- stream )
23 swap normalize-path (file-appender) swap <encoder> ;
25 : file-lines ( path encoding -- seq )
28 : with-file-reader ( path encoding quot -- )
29 >r <file-reader> r> with-input-stream ; inline
31 : file-contents ( path encoding -- str )
32 <file-reader> contents ;
34 : with-file-writer ( path encoding quot -- )
35 >r <file-writer> r> with-output-stream ; inline
37 : set-file-lines ( seq path encoding -- )
38 [ [ print ] each ] with-file-writer ;
40 : set-file-contents ( str path encoding -- )
41 [ write ] with-file-writer ;
43 : with-file-appender ( path encoding quot -- )
44 >r <file-appender> r> with-output-stream ; inline
47 : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
49 : path-separator ( -- string ) os windows? "\\" "/" ? ;
51 : trim-right-separators ( str -- newstr )
52 [ path-separator? ] trim-right ;
54 : trim-left-separators ( str -- newstr )
55 [ path-separator? ] trim-left ;
57 : last-path-separator ( path -- n ? )
58 [ length 1- ] keep [ path-separator? ] find-last-from ;
60 HOOK: root-directory? io-backend ( path -- ? )
62 M: object root-directory? ( path -- ? )
63 [ f ] [ [ path-separator? ] all? ] if-empty ;
65 ERROR: no-parent-directory path ;
67 : parent-directory ( path -- parent )
70 dup last-path-separator [
75 { "" "." ".." } member? [
82 : head-path-separator? ( path1 ? -- ?' )
84 [ t ] [ first path-separator? ] if-empty
89 : head.? ( path -- ? ) "." ?head head-path-separator? ;
91 : head..? ( path -- ? ) ".." ?head head-path-separator? ;
93 : append-path-empty ( path1 path2 -- path' )
96 rest trim-left-separators append-path-empty
98 { [ dup head..? ] [ drop no-parent-directory ] }
104 : windows-absolute-path? ( path -- path ? )
106 { [ dup "\\\\?\\" head? ] [ t ] }
107 { [ dup length 2 < ] [ f ] }
108 { [ dup second CHAR: : = ] [ t ] }
112 : absolute-path? ( path -- ? )
114 { [ dup empty? ] [ f ] }
115 { [ dup "resource:" head? ] [ t ] }
116 { [ os windows? ] [ windows-absolute-path? ] }
117 { [ dup first path-separator? ] [ t ] }
121 : append-path ( str1 str2 -- str )
123 { [ over empty? ] [ append-path-empty ] }
124 { [ dup empty? ] [ drop ] }
125 { [ over trim-right-separators "." = ] [ nip ] }
126 { [ dup absolute-path? ] [ nip ] }
127 { [ dup head.? ] [ rest trim-left-separators append-path ] }
129 2 tail trim-left-separators
130 >r parent-directory r> append-path
132 { [ over absolute-path? over first path-separator? and ] [
136 >r trim-right-separators "/" r>
137 trim-left-separators 3append
141 : prepend-path ( str1 str2 -- str )
142 swap append-path ; inline
144 : file-name ( path -- string )
145 dup root-directory? [
146 trim-right-separators
147 dup last-path-separator [ 1+ tail ] [
148 drop "resource:" ?head [ file-name ] when
152 : file-extension ( filename -- extension )
153 "." last-split1 nip ;
156 TUPLE: file-info type size permissions modified ;
158 HOOK: file-info io-backend ( path -- info )
161 HOOK: link-info io-backend ( path -- info )
163 HOOK: make-link io-backend ( target symlink -- )
165 HOOK: read-link io-backend ( symlink -- path )
167 : copy-link ( target symlink -- )
168 >r read-link r> make-link ;
170 SYMBOL: +regular-file+
172 SYMBOL: +symbolic-link+
173 SYMBOL: +character-device+
174 SYMBOL: +block-device+
180 : exists? ( path -- ? ) normalize-path (exists?) ;
182 : directory? ( file-info -- ? ) type>> +directory+ = ;
186 HOOK: cd io-backend ( path -- )
188 HOOK: cwd io-backend ( -- path )
190 M: object cwd ( -- path ) "." ;
194 SYMBOL: current-directory
197 cwd current-directory set-global
198 13 getenv cwd prepend-path \ image set-global
199 14 getenv cwd prepend-path \ vm set-global
200 image parent-directory "resource-path" set-global
201 ] "io.files" add-init-hook
203 : resource-path ( path -- newpath )
204 "resource-path" get prepend-path ;
206 : (normalize-path) ( path -- path' )
208 trim-left-separators resource-path
211 current-directory get prepend-path
214 M: object normalize-path ( path -- path' )
217 : set-current-directory ( path -- )
218 (normalize-path) current-directory set ;
220 : with-directory ( path quot -- )
221 >r (normalize-path) current-directory r> with-variable ; inline
223 ! Creating directories
224 HOOK: make-directory io-backend ( path -- )
226 : make-directories ( path -- )
227 normalize-path trim-right-separators {
228 { [ dup "." = ] [ ] }
229 { [ dup root-directory? ] [ ] }
230 { [ dup empty? ] [ ] }
231 { [ dup exists? ] [ ] }
233 dup parent-directory make-directories
239 : fixup-directory ( path seq -- newseq )
242 [ tuck append-path file-info directory? 2array ] [ nip ] if
244 [ first { "." ".." } member? not ] filter ;
246 : directory ( path -- seq )
247 normalize-directory dup (directory) fixup-directory ;
249 : directory* ( path -- seq )
250 dup directory [ first2 >r append-path r> 2array ] with map ;
253 HOOK: touch-file io-backend ( path -- )
256 HOOK: delete-file io-backend ( path -- )
258 HOOK: delete-directory io-backend ( path -- )
260 : delete-tree ( path -- )
261 dup link-info type>> +directory+ = [
263 [ first delete-tree ] each
264 ] with-directory delete-directory
269 : to-directory ( from to -- from to' )
270 over file-name append-path ;
272 ! Moving and renaming files
273 HOOK: move-file io-backend ( from to -- )
275 : move-file-into ( from to -- )
276 to-directory move-file ;
278 : move-files-into ( files to -- )
279 [ move-file-into ] curry each ;
282 HOOK: copy-file io-backend ( from to -- )
285 dup parent-directory make-directories
286 binary <file-writer> [
287 swap binary <file-reader> [
292 : copy-file-into ( from to -- )
293 to-directory copy-file ;
295 : copy-files-into ( files to -- )
296 [ copy-file-into ] curry each ;
298 DEFER: copy-tree-into
300 : copy-tree ( from to -- )
302 over link-info type>>
304 { +symbolic-link+ [ copy-link ] }
306 >r dup directory r> rot [
307 [ >r first r> copy-tree-into ] curry each
313 : copy-tree-into ( from to -- )
314 to-directory copy-tree ;
316 : copy-trees-into ( files to -- )
317 [ copy-tree-into ] curry each ;
321 : temp-directory ( -- path )
322 "temp" resource-path dup make-directories ;
324 : temp-file ( name -- path )
325 temp-directory prepend-path ;
327 ! Pathname presentations
328 TUPLE: pathname string ;
330 C: <pathname> pathname
332 M: pathname <=> [ string>> ] compare ;
335 HOOK: home os ( -- dir )
337 M: winnt home "USERPROFILE" os-env ;
339 M: wince home "" resource-path ;
341 M: unix home "HOME" os-env ;