1 ! Copyright (C) 2008 Doug Coleman.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors kernel system math math.bitwise strings arrays
4 sequences combinators combinators.short-circuit alien.c-types
5 vocabs.loader calendar calendar.unix io.files.info
6 io.files.types io.backend io.directories unix unix.stat unix.time unix.users
10 TUPLE: unix-file-system-info < file-system-info
11 block-size preferred-block-size
12 blocks blocks-free blocks-available
13 files files-free files-available
16 HOOK: new-file-system-info os ( -- file-system-info )
18 M: unix new-file-system-info ( -- ) unix-file-system-info new ;
20 HOOK: file-system-statfs os ( path -- statfs )
22 M: unix file-system-statfs drop f ;
24 HOOK: file-system-statvfs os ( path -- statvfs )
26 M: unix file-system-statvfs drop f ;
28 HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
30 M: unix statfs>file-system-info drop ;
32 HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
34 M: unix statvfs>file-system-info drop ;
36 : file-system-calculations ( file-system-info -- file-system-info' )
37 dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space
38 dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space
39 dup [ blocks>> ] [ block-size>> ] bi * >>total-space
40 dup [ total-space>> ] [ free-space>> ] bi - >>used-space ;
42 M: unix file-system-info
44 [ new-file-system-info ] dip
45 [ file-system-statfs statfs>file-system-info ]
46 [ file-system-statvfs statvfs>file-system-info ] bi
47 file-system-calculations ;
49 TUPLE: unix-file-info < file-info uid gid dev ino
50 nlink rdev blocks blocksize ;
52 HOOK: new-file-info os ( -- file-info )
54 HOOK: stat>file-info os ( stat -- file-info )
56 HOOK: stat>type os ( stat -- file-info )
58 M: unix file-info ( path -- info )
59 normalize-path file-status stat>file-info ;
61 M: unix link-info ( path -- info )
62 normalize-path link-status stat>file-info ;
64 M: unix new-file-info ( -- class ) unix-file-info new ;
66 CONSTANT: standard-unix-block-size 512
68 M: unix stat>file-info ( stat -- file-info )
72 [ stat-st_size >>size ]
73 [ stat-st_mode >>permissions ]
74 [ stat-st_ctimespec timespec>unix-time >>created ]
75 [ stat-st_mtimespec timespec>unix-time >>modified ]
76 [ stat-st_atimespec timespec>unix-time >>accessed ]
81 [ stat-st_nlink >>nlink ]
82 [ stat-st_rdev >>rdev ]
83 [ stat-st_blocks >>blocks ]
84 [ stat-st_blksize >>blocksize ]
85 [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
88 : n>file-type ( n -- type )
90 { S_IFREG [ +regular-file+ ] }
91 { S_IFDIR [ +directory+ ] }
92 { S_IFCHR [ +character-device+ ] }
93 { S_IFBLK [ +block-device+ ] }
94 { S_IFIFO [ +fifo+ ] }
95 { S_IFLNK [ +symbolic-link+ ] }
96 { S_IFSOCK [ +socket+ ] }
100 M: unix stat>type ( stat -- type )
101 stat-st_mode n>file-type ;
105 : stat-mode ( path -- mode )
106 normalize-path file-status stat-st_mode ;
108 : chmod-set-bit ( path mask ? -- )
109 [ dup stat-mode ] 2dip
110 [ bitor ] [ unmask ] if chmod io-error ;
112 GENERIC# file-mode? 1 ( obj mask -- ? )
114 M: integer file-mode? mask? ;
115 M: string file-mode? [ stat-mode ] dip mask? ;
116 M: file-info file-mode? [ permissions>> ] dip mask? ;
120 CONSTANT: UID OCT: 0004000
121 CONSTANT: GID OCT: 0002000
122 CONSTANT: STICKY OCT: 0001000
123 CONSTANT: USER-ALL OCT: 0000700
124 CONSTANT: USER-READ OCT: 0000400
125 CONSTANT: USER-WRITE OCT: 0000200
126 CONSTANT: USER-EXECUTE OCT: 0000100
127 CONSTANT: GROUP-ALL OCT: 0000070
128 CONSTANT: GROUP-READ OCT: 0000040
129 CONSTANT: GROUP-WRITE OCT: 0000020
130 CONSTANT: GROUP-EXECUTE OCT: 0000010
131 CONSTANT: OTHER-ALL OCT: 0000007
132 CONSTANT: OTHER-READ OCT: 0000004
133 CONSTANT: OTHER-WRITE OCT: 0000002
134 CONSTANT: OTHER-EXECUTE OCT: 0000001
136 : uid? ( obj -- ? ) UID file-mode? ;
137 : gid? ( obj -- ? ) GID file-mode? ;
138 : sticky? ( obj -- ? ) STICKY file-mode? ;
139 : user-read? ( obj -- ? ) USER-READ file-mode? ;
140 : user-write? ( obj -- ? ) USER-WRITE file-mode? ;
141 : user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
142 : group-read? ( obj -- ? ) GROUP-READ file-mode? ;
143 : group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
144 : group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
145 : other-read? ( obj -- ? ) OTHER-READ file-mode? ;
146 : other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
147 : other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
149 : any-read? ( obj -- ? )
150 { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
152 : any-write? ( obj -- ? )
153 { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
155 : any-execute? ( obj -- ? )
156 { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
158 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
159 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
160 : set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
161 : set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
162 : set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
163 : set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
164 : set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
165 : set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
166 : set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
167 : set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
168 : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
169 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
171 : set-file-permissions ( path n -- )
172 [ normalize-path ] dip chmod io-error ;
174 : file-permissions ( path -- n )
175 normalize-path file-info permissions>> ;
177 M: unix copy-file-and-info ( from to -- )
178 [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
182 : make-timeval-array ( array -- byte-array )
183 [ [ "timeval" <c-object> ] unless* ] map concat ;
185 : timestamp>timeval ( timestamp -- timeval )
186 unix-1970 time- duration>microseconds make-timeval ;
188 : timestamps>byte-array ( timestamps -- byte-array )
189 [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
193 : set-file-times ( path timestamps -- )
195 [ normalize-path ] dip
196 timestamps>byte-array utimes io-error ;
198 : set-file-access-time ( path timestamp -- )
199 f 2array set-file-times ;
201 : set-file-modified-time ( path timestamp -- )
202 f swap 2array set-file-times ;
204 : set-file-ids ( path uid gid -- )
205 [ normalize-path ] 2dip
206 [ [ -1 ] unless* ] bi@ chown io-error ;
208 GENERIC: set-file-user ( path string/id -- )
210 GENERIC: set-file-group ( path string/id -- )
212 M: integer set-file-user ( path uid -- )
215 M: string set-file-user ( path string -- )
216 user-id f set-file-ids ;
218 M: integer set-file-group ( path gid -- )
219 f swap set-file-ids ;
221 M: string set-file-group ( path string -- )
223 f swap set-file-ids ;
225 : file-user-id ( path -- uid )
226 normalize-path file-info uid>> ;
228 : file-user-name ( path -- string )
229 file-user-id user-name ;
231 : file-group-id ( path -- gid )
232 normalize-path file-info gid>> ;
234 : file-group-name ( path -- string )
235 file-group-id group-name ;
237 : ch>file-type ( ch -- type )
239 { CHAR: b [ +block-device+ ] }
240 { CHAR: c [ +character-device+ ] }
241 { CHAR: d [ +directory+ ] }
242 { CHAR: l [ +symbolic-link+ ] }
243 { CHAR: s [ +socket+ ] }
244 { CHAR: p [ +fifo+ ] }
245 { CHAR: - [ +regular-file+ ] }
249 : file-type>ch ( type -- ch )
251 { +block-device+ [ CHAR: b ] }
252 { +character-device+ [ CHAR: c ] }
253 { +directory+ [ CHAR: d ] }
254 { +symbolic-link+ [ CHAR: l ] }
255 { +socket+ [ CHAR: s ] }
256 { +fifo+ [ CHAR: p ] }
257 { +regular-file+ [ CHAR: - ] }
263 : file-type>executable ( directory-entry -- string )
264 name>> any-execute? "*" "" ? ;
268 : file-type>trailing ( directory-entry -- string )
271 { +directory+ [ drop "/" ] }
272 { +symbolic-link+ [ drop "@" ] }
273 { +fifo+ [ drop "|" ] }
274 { +socket+ [ drop "=" ] }
275 { +whiteout+ [ drop "%" ] }
276 { +unknown+ [ file-type>executable ] }
277 { +regular-file+ [ file-type>executable ] }
278 [ drop file-type>executable ]