1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.data arrays calendar
4 calendar.unix classes.struct combinators
5 combinators.short-circuit io.backend io.files.info
6 io.files.types kernel libc literals math math.bitwise
7 sequences specialized-arrays strings system unix unix.ffi
8 unix.groups unix.stat unix.time unix.users vocabs ;
10 SPECIALIZED-ARRAY: timeval
12 TUPLE: unix-file-system-info < file-system-info-tuple
13 block-size preferred-block-size
14 blocks blocks-free blocks-available
15 files files-free files-available
18 HOOK: new-file-system-info os ( -- file-system-info )
20 M: unix new-file-system-info unix-file-system-info new ;
22 HOOK: file-system-statfs os ( path -- statfs )
24 M: unix file-system-statfs drop f ;
26 HOOK: file-system-statvfs os ( path -- statvfs )
28 M: unix file-system-statvfs drop f ;
30 HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
32 M: unix statfs>file-system-info drop ;
34 HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
36 M: unix statvfs>file-system-info drop ;
38 : file-system-calculations ( file-system-info -- file-system-info' )
39 dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space
40 dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space
41 dup [ blocks>> ] [ block-size>> ] bi * >>total-space
42 dup [ total-space>> ] [ free-space>> ] bi - >>used-space ;
44 M: unix file-system-info
46 [ new-file-system-info ] dip
47 [ file-system-statfs statfs>file-system-info ]
48 [ file-system-statvfs statvfs>file-system-info ] bi
49 file-system-calculations ;
51 TUPLE: unix-file-info < file-info-tuple uid gid dev ino
52 nlink rdev blocks blocksize ;
54 HOOK: new-file-info os ( -- file-info )
56 HOOK: stat>file-info os ( stat -- file-info )
58 HOOK: stat>type os ( stat -- file-info )
60 M: unix file-info ( path -- info )
61 normalize-path file-status stat>file-info ;
63 M: unix link-info ( path -- info )
64 normalize-path link-status stat>file-info ;
66 M: unix new-file-info ( -- class ) unix-file-info new ;
68 CONSTANT: standard-unix-block-size 512
70 M: unix stat>file-info ( stat -- file-info )
75 [ st_mode>> >>permissions ]
76 [ st_ctimespec>> timespec>unix-time >>created ]
77 [ st_mtimespec>> timespec>unix-time >>modified ]
78 [ st_atimespec>> timespec>unix-time >>accessed ]
83 [ st_nlink>> >>nlink ]
85 [ st_blocks>> >>blocks ]
86 [ st_blksize>> >>blocksize ]
87 [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
90 : n>file-type ( n -- type )
92 { S_IFREG [ +regular-file+ ] }
93 { S_IFDIR [ +directory+ ] }
94 { S_IFCHR [ +character-device+ ] }
95 { S_IFBLK [ +block-device+ ] }
96 { S_IFIFO [ +fifo+ ] }
97 { S_IFLNK [ +symbolic-link+ ] }
98 { S_IFSOCK [ +socket+ ] }
102 M: unix stat>type ( stat -- type )
103 st_mode>> n>file-type ;
107 : stat-mode ( path -- mode )
108 normalize-path file-status st_mode>> ;
110 : chmod-set-bit ( path mask ? -- )
111 [ dup stat-mode ] 2dip
112 [ bitor ] [ unmask ] if [ chmod ] unix-system-call drop ;
114 GENERIC# file-mode? 1 ( obj mask -- ? )
116 M: integer file-mode? mask? ;
117 M: string file-mode? [ stat-mode ] dip mask? ;
118 M: file-info-tuple file-mode? [ permissions>> ] dip mask? ;
122 CONSTANT: UID 0o0004000
123 CONSTANT: GID 0o0002000
124 CONSTANT: STICKY 0o0001000
125 CONSTANT: USER-ALL 0o0000700
126 CONSTANT: USER-READ 0o0000400
127 CONSTANT: USER-WRITE 0o0000200
128 CONSTANT: USER-EXECUTE 0o0000100
129 CONSTANT: GROUP-ALL 0o0000070
130 CONSTANT: GROUP-READ 0o0000040
131 CONSTANT: GROUP-WRITE 0o0000020
132 CONSTANT: GROUP-EXECUTE 0o0000010
133 CONSTANT: OTHER-ALL 0o0000007
134 CONSTANT: OTHER-READ 0o0000004
135 CONSTANT: OTHER-WRITE 0o0000002
136 CONSTANT: OTHER-EXECUTE 0o0000001
137 CONSTANT: ALL-READ 0o0000444
138 CONSTANT: ALL-WRITE 0o0000222
139 CONSTANT: ALL-EXECUTE 0o0000111
141 : uid? ( obj -- ? ) UID file-mode? ;
142 : gid? ( obj -- ? ) GID file-mode? ;
143 : sticky? ( obj -- ? ) STICKY file-mode? ;
144 : user-read? ( obj -- ? ) USER-READ file-mode? ;
145 : user-write? ( obj -- ? ) USER-WRITE file-mode? ;
146 : user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
147 : group-read? ( obj -- ? ) GROUP-READ file-mode? ;
148 : group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
149 : group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
150 : other-read? ( obj -- ? ) OTHER-READ file-mode? ;
151 : other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
152 : other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
154 : any-read? ( obj -- ? )
155 { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
157 : any-write? ( obj -- ? )
158 { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
160 : any-execute? ( obj -- ? )
161 { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
163 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
164 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
165 : set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
166 : set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
167 : set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
168 : set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
169 : set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
170 : set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
171 : set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
172 : set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
173 : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
174 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
176 : set-file-permissions ( path n -- )
177 [ normalize-path ] dip [ chmod ] unix-system-call drop ;
179 : file-permissions ( path -- n )
180 normalize-path file-info permissions>> ;
182 : add-file-permissions ( path n -- )
183 over file-permissions bitor set-file-permissions ;
185 : remove-file-permissions ( path n -- )
186 over file-permissions [ bitnot ] dip bitand set-file-permissions ;
190 : timestamp>timeval ( timestamp -- timeval )
191 unix-1970 time- duration>microseconds make-timeval ;
193 : timestamps>byte-array ( timestamps -- byte-array )
194 [ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
199 : set-file-times ( path timestamps -- )
201 [ normalize-path ] dip
202 timestamps>byte-array [ utimes ] unix-system-call drop ;
204 : set-file-access-time ( path timestamp -- )
205 over file-info modified>> 2array set-file-times ;
207 : set-file-modified-time ( path timestamp -- )
208 over file-info accessed>> swap 2array set-file-times ;
210 : set-file-ids ( path uid gid -- )
211 [ normalize-path ] 2dip [ -1 or ] bi@
212 [ chown ] unix-system-call drop ;
214 GENERIC: set-file-user ( path string/id -- )
216 GENERIC: set-file-group ( path string/id -- )
218 M: integer set-file-user ( path uid -- )
221 M: string set-file-user ( path string -- )
222 user-id f set-file-ids ;
224 M: integer set-file-group ( path gid -- )
225 f swap set-file-ids ;
227 M: string set-file-group ( path string -- )
229 f swap set-file-ids ;
231 : file-user-id ( path -- uid )
232 normalize-path file-info uid>> ;
234 : file-user-name ( path -- string )
235 file-user-id user-name ;
237 : file-group-id ( path -- gid )
238 normalize-path file-info gid>> ;
240 : file-group-name ( path -- string )
241 file-group-id group-name ;
243 : ch>file-type ( ch -- type )
245 { CHAR: b [ +block-device+ ] }
246 { CHAR: c [ +character-device+ ] }
247 { CHAR: d [ +directory+ ] }
248 { CHAR: l [ +symbolic-link+ ] }
249 { CHAR: s [ +socket+ ] }
250 { CHAR: p [ +fifo+ ] }
251 { CHAR: - [ +regular-file+ ] }
255 : file-type>ch ( type -- ch )
257 { +block-device+ [ CHAR: b ] }
258 { +character-device+ [ CHAR: c ] }
259 { +directory+ [ CHAR: d ] }
260 { +symbolic-link+ [ CHAR: l ] }
261 { +socket+ [ CHAR: s ] }
262 { +fifo+ [ CHAR: p ] }
263 { +regular-file+ [ CHAR: - ] }
269 : file-type>executable ( directory-entry -- string )
270 name>> any-execute? "*" "" ? ;
274 : file-type>trailing ( directory-entry -- string )
277 { +directory+ [ drop "/" ] }
278 { +symbolic-link+ [ drop "@" ] }
279 { +fifo+ [ drop "|" ] }
280 { +socket+ [ drop "=" ] }
281 { +whiteout+ [ drop "%" ] }
282 { +unknown+ [ file-type>executable ] }
283 { +regular-file+ [ file-type>executable ] }
284 [ drop file-type>executable ]
289 : access? ( path mode -- ? )
290 [ normalize-path ] [ access ] bi* 0 < [
291 errno EACCES = [ f ] [ throw-errno ] if
296 M: unix file-readable? R_OK access? ;
297 M: unix file-writable? W_OK access? ;
298 M: unix file-executable? X_OK access? ;
300 "io.files.info.unix." os name>> append require