1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: io.backend io.ports io.unix.backend io.files io
4 unix unix.stat unix.time kernel math continuations
5 math.bitwise byte-arrays alien combinators calendar
6 io.encodings.binary accessors sequences strings system
7 io.files.private destructors vocabs.loader calendar.unix
8 unix.stat alien.c-types arrays unix.users unix.groups
9 environment fry io.encodings.utf8 alien.strings
10 combinators.short-circuit ;
13 M: unix cwd ( -- path )
14 MAXPATHLEN [ <byte-array> ] keep getcwd
15 [ (io-error) ] unless* ;
17 M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
19 : read-flags O_RDONLY ; inline
21 : open-read ( path -- fd ) O_RDONLY file-mode open-file ;
23 M: unix (file-reader) ( path -- stream )
24 open-read <fd> init-fd <input-port> ;
26 : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
28 : open-write ( path -- fd )
29 write-flags file-mode open-file ;
31 M: unix (file-writer) ( path -- stream )
32 open-write <fd> init-fd <output-port> ;
34 : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
36 : open-append ( path -- fd )
38 append-flags file-mode open-file |dispose
39 dup 0 SEEK_END lseek io-error
42 M: unix (file-appender) ( path -- stream )
43 open-append <fd> init-fd <output-port> ;
46 { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
48 M: unix touch-file ( path -- )
50 dup exists? [ touch ] [
51 touch-mode file-mode open-file close-file
54 M: unix move-file ( from to -- )
55 [ normalize-path ] bi@ rename io-error ;
57 M: unix delete-file ( path -- ) normalize-path unlink-file ;
59 M: unix make-directory ( path -- )
60 normalize-path OCT: 777 mkdir io-error ;
62 M: unix delete-directory ( path -- )
63 normalize-path rmdir io-error ;
65 : (copy-file) ( from to -- )
66 dup parent-directory make-directories
67 binary <file-writer> [
68 swap binary <file-reader> [
73 M: unix copy-file ( from to -- )
74 [ normalize-path ] bi@
76 [ swap file-info permissions>> chmod io-error ]
79 TUPLE: unix-file-system-info < file-system-info
80 block-size preferred-block-size
81 blocks blocks-free blocks-available
82 files files-free files-available
85 HOOK: new-file-system-info os ( -- file-system-info )
87 M: unix new-file-system-info ( -- ) unix-file-system-info new ;
89 HOOK: file-system-statfs os ( path -- statfs )
91 M: unix file-system-statfs drop f ;
93 HOOK: file-system-statvfs os ( path -- statvfs )
95 M: unix file-system-statvfs drop f ;
97 HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
99 M: unix statfs>file-system-info drop ;
101 HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
103 M: unix statvfs>file-system-info drop ;
105 : file-system-calculations ( file-system-info -- file-system-info' )
107 [ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space drop ]
108 [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ]
109 [ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
110 [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
114 M: unix file-system-info
116 [ new-file-system-info ] dip
117 [ file-system-statfs statfs>file-system-info ]
118 [ file-system-statvfs statvfs>file-system-info ] bi
119 file-system-calculations ;
122 { linux [ "io.unix.files.linux" require ] }
123 { macosx [ "io.unix.files.macosx" require ] }
124 { freebsd [ "io.unix.files.freebsd" require ] }
125 { netbsd [ "io.unix.files.netbsd" require ] }
126 { openbsd [ "io.unix.files.openbsd" require ] }
129 TUPLE: unix-file-info < file-info uid gid dev ino
130 nlink rdev blocks blocksize ;
132 HOOK: new-file-info os ( -- file-info )
134 HOOK: stat>file-info os ( stat -- file-info )
136 HOOK: stat>type os ( stat -- file-info )
138 M: unix file-info ( path -- info )
139 normalize-path file-status stat>file-info ;
141 M: unix link-info ( path -- info )
142 normalize-path link-status stat>file-info ;
144 M: unix make-link ( path1 path2 -- )
145 normalize-path symlink io-error ;
147 M: unix read-link ( path -- path' )
148 normalize-path read-symbolic-link ;
150 M: unix new-file-info ( -- class ) unix-file-info new ;
152 M: unix stat>file-info ( stat -- file-info )
153 [ new-file-info ] dip
156 [ stat-st_size >>size ]
157 [ stat-st_mode >>permissions ]
158 [ stat-st_ctimespec timespec>unix-time >>created ]
159 [ stat-st_mtimespec timespec>unix-time >>modified ]
160 [ stat-st_atimespec timespec>unix-time >>accessed ]
161 [ stat-st_uid >>uid ]
162 [ stat-st_gid >>gid ]
163 [ stat-st_dev >>dev ]
164 [ stat-st_ino >>ino ]
165 [ stat-st_nlink >>nlink ]
166 [ stat-st_rdev >>rdev ]
167 [ stat-st_blocks >>blocks ]
168 [ stat-st_blksize >>blocksize ]
171 : n>file-type ( n -- type )
173 { S_IFREG [ +regular-file+ ] }
174 { S_IFDIR [ +directory+ ] }
175 { S_IFCHR [ +character-device+ ] }
176 { S_IFBLK [ +block-device+ ] }
177 { S_IFIFO [ +fifo+ ] }
178 { S_IFLNK [ +symbolic-link+ ] }
179 { S_IFSOCK [ +socket+ ] }
183 M: unix stat>type ( stat -- type )
184 stat-st_mode n>file-type ;
186 ! Linux has no extra fields in its stat struct
188 { macosx [ "io.unix.files.bsd" require ] }
189 { netbsd [ "io.unix.files.bsd" require ] }
190 { openbsd [ "io.unix.files.bsd" require ] }
191 { freebsd [ "io.unix.files.bsd" require ] }
195 : with-unix-directory ( path quot -- )
196 [ opendir dup [ (io-error) ] unless ] dip
197 dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
199 : find-next-file ( DIR* -- byte-array )
202 [ readdir_r 0 = [ (io-error) ] unless ] 2keep
203 *void* [ drop f ] unless ;
205 M: unix >directory-entry ( byte-array -- directory-entry )
206 [ dirent-d_name utf8 alien>string ]
207 [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
209 M: unix (directory-entries) ( path -- seq )
211 '[ _ find-next-file dup ]
214 ] with-unix-directory ;
218 : stat-mode ( path -- mode )
219 normalize-path file-status stat-st_mode ;
221 : chmod-set-bit ( path mask ? -- )
222 [ dup stat-mode ] 2dip
223 [ bitor ] [ unmask ] if chmod io-error ;
225 GENERIC# file-mode? 1 ( obj mask -- ? )
227 M: integer file-mode? mask? ;
228 M: string file-mode? [ stat-mode ] dip mask? ;
229 M: file-info file-mode? [ permissions>> ] dip mask? ;
233 : ch>file-type ( ch -- type )
235 { CHAR: b [ +block-device+ ] }
236 { CHAR: c [ +character-device+ ] }
237 { CHAR: d [ +directory+ ] }
238 { CHAR: l [ +symbolic-link+ ] }
239 { CHAR: s [ +socket+ ] }
240 { CHAR: p [ +fifo+ ] }
241 { CHAR: - [ +regular-file+ ] }
245 : file-type>ch ( type -- string )
247 { +block-device+ [ CHAR: b ] }
248 { +character-device+ [ CHAR: c ] }
249 { +directory+ [ CHAR: d ] }
250 { +symbolic-link+ [ CHAR: l ] }
251 { +socket+ [ CHAR: s ] }
252 { +fifo+ [ CHAR: p ] }
253 { +regular-file+ [ CHAR: - ] }
257 : UID OCT: 0004000 ; inline
258 : GID OCT: 0002000 ; inline
259 : STICKY OCT: 0001000 ; inline
260 : USER-ALL OCT: 0000700 ; inline
261 : USER-READ OCT: 0000400 ; inline
262 : USER-WRITE OCT: 0000200 ; inline
263 : USER-EXECUTE OCT: 0000100 ; inline
264 : GROUP-ALL OCT: 0000070 ; inline
265 : GROUP-READ OCT: 0000040 ; inline
266 : GROUP-WRITE OCT: 0000020 ; inline
267 : GROUP-EXECUTE OCT: 0000010 ; inline
268 : OTHER-ALL OCT: 0000007 ; inline
269 : OTHER-READ OCT: 0000004 ; inline
270 : OTHER-WRITE OCT: 0000002 ; inline
271 : OTHER-EXECUTE OCT: 0000001 ; inline
273 : uid? ( obj -- ? ) UID file-mode? ;
274 : gid? ( obj -- ? ) GID file-mode? ;
275 : sticky? ( obj -- ? ) STICKY file-mode? ;
276 : user-read? ( obj -- ? ) USER-READ file-mode? ;
277 : user-write? ( obj -- ? ) USER-WRITE file-mode? ;
278 : user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
279 : group-read? ( obj -- ? ) GROUP-READ file-mode? ;
280 : group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
281 : group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
282 : other-read? ( obj -- ? ) OTHER-READ file-mode? ;
283 : other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
284 : other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
286 : any-read? ( obj -- ? )
287 { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
289 : any-write? ( obj -- ? )
290 { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
292 : any-execute? ( obj -- ? )
293 { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
295 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
296 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
297 : set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
298 : set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
299 : set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
300 : set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
301 : set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
302 : set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
303 : set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
304 : set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
305 : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
306 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
308 : set-file-permissions ( path n -- )
309 [ normalize-path ] dip chmod io-error ;
311 : file-permissions ( path -- n )
312 normalize-path file-info permissions>> ;
316 : make-timeval-array ( array -- byte-array )
317 [ [ "timeval" <c-object> ] unless* ] map concat ;
319 : timestamp>timeval ( timestamp -- timeval )
320 unix-1970 time- duration>microseconds make-timeval ;
322 : timestamps>byte-array ( timestamps -- byte-array )
323 [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
327 : set-file-times ( path timestamps -- )
329 [ normalize-path ] dip
330 timestamps>byte-array utimes io-error ;
332 : set-file-access-time ( path timestamp -- )
333 f 2array set-file-times ;
335 : set-file-modified-time ( path timestamp -- )
336 f swap 2array set-file-times ;
338 : set-file-ids ( path uid gid -- )
339 [ normalize-path ] 2dip
340 [ [ -1 ] unless* ] bi@ chown io-error ;
342 GENERIC: set-file-user ( path string/id -- )
344 GENERIC: set-file-group ( path string/id -- )
346 M: integer set-file-user ( path uid -- )
349 M: string set-file-user ( path string -- )
350 user-id f set-file-ids ;
352 M: integer set-file-group ( path gid -- )
353 f swap set-file-ids ;
355 M: string set-file-group ( path string -- )
357 f swap set-file-ids ;
359 : file-user-id ( path -- uid )
360 normalize-path file-info uid>> ;
362 : file-username ( path -- string )
363 file-user-id username ;
365 : file-group-id ( path -- gid )
366 normalize-path file-info gid>> ;
368 : file-group-name ( path -- string )
369 file-group-id group-name ;
371 M: unix home "HOME" os-env ;