basis/io/files/info/unix/unix.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.data arrays calendar calendar.unix
   4 classes.struct combinators combinators.short-circuit io.backend
   5 io.files.info io.files.types kernel libc math math.bitwise
   6 sequences specialized-arrays strings system unix unix.ffi
   7 unix.groups unix.stat unix.time unix.users vocabs ;
   8 IN: io.files.info.unix
   9 SPECIALIZED-ARRAY: timeval
  10
  11 TUPLE: unix-file-system-info < file-system-info-tuple
  12 block-size preferred-block-size
  13 blocks blocks-free blocks-available
  14 files files-free files-available
  15 name-max flags id ;
  16
  17 HOOK: new-file-system-info os ( --  file-system-info )
  18
  19 M: unix new-file-system-info unix-file-system-info new ;
  20
  21 HOOK: file-system-statfs os ( path -- statfs )
  22
  23 M: unix file-system-statfs drop f ;
  24
  25 HOOK: file-system-statvfs os ( path -- statvfs )
  26
  27 M: unix file-system-statvfs drop f ;
  28
  29 HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
  30
  31 M: unix statfs>file-system-info drop ;
  32
  33 HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
  34
  35 M: unix statvfs>file-system-info drop ;
  36
  37 : file-system-calculations ( file-system-info -- file-system-info' )
  38     dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space
  39     dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space
  40     dup [ blocks>> ] [ block-size>> ] bi * >>total-space
  41     dup [ total-space>> ] [ free-space>> ] bi - >>used-space ;
  42
  43 M: unix file-system-info
  44     normalize-path
  45     [ new-file-system-info ] dip
  46     [ file-system-statfs statfs>file-system-info ]
  47     [ file-system-statvfs statvfs>file-system-info ] bi
  48     file-system-calculations ;
  49
  50 TUPLE: unix-file-info < file-info-tuple uid gid dev ino
  51 nlink rdev blocks blocksize ;
  52
  53 HOOK: new-file-info os ( -- file-info )
  54
  55 HOOK: stat>file-info os ( stat -- file-info )
  56
  57 HOOK: stat>type os ( stat -- file-info )
  58
  59 M: unix file-info
  60     normalize-path file-status stat>file-info ;
  61
  62 M: unix link-info
  63     normalize-path link-status stat>file-info ;
  64
  65 M: unix new-file-info unix-file-info new ;
  66
  67 CONSTANT: standard-unix-block-size 512
  68
  69 M: unix stat>file-info
  70     [ new-file-info ] dip
  71     {
  72         [ stat>type >>type ]
  73         [ st_size>> >>size ]
  74         [ st_mode>> >>permissions ]
  75         [ st_ctimespec>> timespec>unix-time >>created ]
  76         [ st_mtimespec>> timespec>unix-time >>modified ]
  77         [ st_atimespec>> timespec>unix-time >>accessed ]
  78         [ st_uid>> >>uid ]
  79         [ st_gid>> >>gid ]
  80         [ st_dev>> >>dev ]
  81         [ st_ino>> >>ino ]
  82         [ st_nlink>> >>nlink ]
  83         [ st_rdev>> >>rdev ]
  84         [ st_blocks>> >>blocks ]
  85         [ st_blksize>> >>blocksize ]
  86         [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
  87     } cleave ;
  88
  89 : n>file-type ( n -- type )
  90     S_IFMT bitand {
  91         { S_IFREG [ +regular-file+ ] }
  92         { S_IFDIR [ +directory+ ] }
  93         { S_IFCHR [ +character-device+ ] }
  94         { S_IFBLK [ +block-device+ ] }
  95         { S_IFIFO [ +fifo+ ] }
  96         { S_IFLNK [ +symbolic-link+ ] }
  97         { S_IFSOCK [ +socket+ ] }
  98         [ drop +unknown+ ]
  99     } case ;
 100
 101 M: unix stat>type
 102     st_mode>> n>file-type ;
 103
 104 <PRIVATE
 105
 106 : stat-mode ( path -- mode )
 107     normalize-path file-status st_mode>> ;
 108
 109 : chmod-set-bit ( path mask ? -- )
 110     [ dup stat-mode ] 2dip
 111     [ bitor ] [ unmask ] if [ chmod ] unix-system-call drop ;
 112
 113 GENERIC#: file-mode? 1 ( obj mask -- ? )
 114
 115 M: integer file-mode? mask? ;
 116 M: string file-mode? [ stat-mode ] dip mask? ;
 117 M: file-info-tuple file-mode? [ permissions>> ] dip mask? ;
 118
 119 PRIVATE>
 120
 121 CONSTANT: UID           0o0004000
 122 CONSTANT: GID           0o0002000
 123 CONSTANT: STICKY        0o0001000
 124 CONSTANT: USER-ALL      0o0000700
 125 CONSTANT: USER-READ     0o0000400
 126 CONSTANT: USER-WRITE    0o0000200
 127 CONSTANT: USER-EXECUTE  0o0000100
 128 CONSTANT: GROUP-ALL     0o0000070
 129 CONSTANT: GROUP-READ    0o0000040
 130 CONSTANT: GROUP-WRITE   0o0000020
 131 CONSTANT: GROUP-EXECUTE 0o0000010
 132 CONSTANT: OTHER-ALL     0o0000007
 133 CONSTANT: OTHER-READ    0o0000004
 134 CONSTANT: OTHER-WRITE   0o0000002
 135 CONSTANT: OTHER-EXECUTE 0o0000001
 136 CONSTANT: ALL-READ      0o0000444
 137 CONSTANT: ALL-WRITE     0o0000222
 138 CONSTANT: ALL-EXECUTE   0o0000111
 139
 140 : uid? ( obj -- ? ) UID file-mode? ;
 141 : gid? ( obj -- ? ) GID file-mode? ;
 142 : sticky? ( obj -- ? ) STICKY file-mode? ;
 143 : user-read? ( obj -- ? ) USER-READ file-mode? ;
 144 : user-write? ( obj -- ? ) USER-WRITE file-mode? ;
 145 : user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
 146 : group-read? ( obj -- ? ) GROUP-READ file-mode? ;
 147 : group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
 148 : group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
 149 : other-read? ( obj -- ? ) OTHER-READ file-mode? ;
 150 : other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
 151 : other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
 152
 153 : any-read? ( obj -- ? )
 154     { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
 155
 156 : any-write? ( obj -- ? )
 157     { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
 158
 159 : any-execute? ( obj -- ? )
 160     { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
 161
 162 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
 163 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
 164 : set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
 165 : set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
 166 : set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
 167 : set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
 168 : set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
 169 : set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
 170 : set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
 171 : set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
 172 : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
 173 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
 174
 175 : set-file-permissions ( path n -- )
 176     [ normalize-path ] dip [ chmod ] unix-system-call drop ;
 177
 178 : file-permissions ( path -- n )
 179     normalize-path file-info permissions>> ;
 180
 181 : add-file-permissions ( path n -- )
 182     over file-permissions bitor set-file-permissions ;
 183
 184 : remove-file-permissions ( path n -- )
 185     over file-permissions [ bitnot ] dip bitand set-file-permissions ;
 186
 187 <PRIVATE
 188
 189 : timestamp>timeval ( timestamp -- timeval )
 190     unix-1970 time- duration>microseconds make-timeval ;
 191
 192 : timestamps>byte-array ( timestamps -- byte-array )
 193     [ [ timestamp>timeval ] [ \ timeval new ] if* ] map
 194     timeval >c-array ;
 195
 196 PRIVATE>
 197
 198 : set-file-times ( path timestamps -- )
 199     ! set access, write
 200     [ normalize-path ] dip
 201     timestamps>byte-array [ utimes ] unix-system-call drop ;
 202
 203 : set-file-access-time ( path timestamp -- )
 204     over file-info modified>> 2array set-file-times ;
 205
 206 : set-file-modified-time ( path timestamp -- )
 207     over file-info accessed>> swap 2array set-file-times ;
 208
 209 : set-file-ids ( path uid gid -- )
 210     [ normalize-path ] 2dip [ -1 or ] bi@
 211     [ chown ] unix-system-call drop ;
 212
 213 GENERIC: set-file-user ( path string/id -- )
 214
 215 GENERIC: set-file-group ( path string/id -- )
 216
 217 M: integer set-file-user
 218     f set-file-ids ;
 219
 220 M: string set-file-user
 221     user-id f set-file-ids ;
 222
 223 M: integer set-file-group
 224     f swap set-file-ids ;
 225
 226 M: string set-file-group
 227     group-id
 228     f swap set-file-ids ;
 229
 230 : file-user-id ( path -- uid )
 231     normalize-path file-info uid>> ;
 232
 233 : file-user-name ( path -- string )
 234     file-user-id user-name ;
 235
 236 : file-group-id ( path -- gid )
 237     normalize-path file-info gid>> ;
 238
 239 : file-group-name ( path -- string )
 240     file-group-id group-name ;
 241
 242 : ch>file-type ( ch -- type )
 243     {
 244         { CHAR: b [ +block-device+ ] }
 245         { CHAR: c [ +character-device+ ] }
 246         { CHAR: d [ +directory+ ] }
 247         { CHAR: l [ +symbolic-link+ ] }
 248         { CHAR: s [ +socket+ ] }
 249         { CHAR: p [ +fifo+ ] }
 250         { CHAR: - [ +regular-file+ ] }
 251         [ drop +unknown+ ]
 252     } case ;
 253
 254 : file-type>ch ( type -- ch )
 255     {
 256         { +block-device+ [ CHAR: b ] }
 257         { +character-device+ [ CHAR: c ] }
 258         { +directory+ [ CHAR: d ] }
 259         { +symbolic-link+ [ CHAR: l ] }
 260         { +socket+ [ CHAR: s ] }
 261         { +fifo+ [ CHAR: p ] }
 262         { +regular-file+ [ CHAR: - ] }
 263         [ drop CHAR: - ]
 264     } case ;
 265
 266 <PRIVATE
 267
 268 : file-type>executable ( directory-entry -- string )
 269     name>> any-execute? "*" "" ? ;
 270
 271 PRIVATE>
 272
 273 : file-type>trailing ( directory-entry -- string )
 274     dup type>>
 275     {
 276         { +directory+ [ drop "/" ] }
 277         { +symbolic-link+ [ drop "@" ] }
 278         { +fifo+ [ drop "|" ] }
 279         { +socket+ [ drop "=" ] }
 280         { +whiteout+ [ drop "%" ] }
 281         { +unknown+ [ file-type>executable ] }
 282         { +regular-file+ [ file-type>executable ] }
 283         [ drop file-type>executable ]
 284     } case ;
 285
 286 <PRIVATE
 287
 288 : access? ( path mode -- ? )
 289     [ normalize-path ] [ access ] bi* 0 < [
 290         errno EACCES = [ f ] [ throw-errno ] if
 291     ] [ t ] if ;
 292
 293 PRIVATE>
 294
 295 M: unix file-readable? R_OK access? ;
 296 M: unix file-writable? W_OK access? ;
 297 M: unix file-executable? X_OK access? ;
 298
 299 "io.files.info.unix." os name>> append require