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 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
   7 unix.groups classes.struct struct-arrays ;
   8 IN: io.files.info.unix
   9
  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
  14 name-max flags id ;
  15
  16 HOOK: new-file-system-info os ( --  file-system-info )
  17
  18 M: unix new-file-system-info ( -- ) unix-file-system-info new ;
  19
  20 HOOK: file-system-statfs os ( path -- statfs )
  21
  22 M: unix file-system-statfs drop f ;
  23
  24 HOOK: file-system-statvfs os ( path -- statvfs )
  25
  26 M: unix file-system-statvfs drop f ;
  27
  28 HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
  29
  30 M: unix statfs>file-system-info drop ;
  31
  32 HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
  33
  34 M: unix statvfs>file-system-info drop ;
  35
  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 ;
  41
  42 M: unix file-system-info
  43     normalize-path
  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 ;
  48
  49 TUPLE: unix-file-info < file-info uid gid dev ino
  50 nlink rdev blocks blocksize ;
  51
  52 HOOK: new-file-info os ( -- file-info )
  53
  54 HOOK: stat>file-info os ( stat -- file-info )
  55
  56 HOOK: stat>type os ( stat -- file-info )
  57
  58 M: unix file-info ( path -- info )
  59     normalize-path file-status stat>file-info ;
  60
  61 M: unix link-info ( path -- info )
  62     normalize-path link-status stat>file-info ;
  63
  64 M: unix new-file-info ( -- class ) unix-file-info new ;
  65
  66 CONSTANT: standard-unix-block-size 512
  67
  68 M: unix stat>file-info ( stat -- file-info )
  69     [ new-file-info ] dip
  70     {
  71         [ stat>type >>type ]
  72         [ st_size>> >>size ]
  73         [ st_mode>> >>permissions ]
  74         [ st_ctimespec>> timespec>unix-time >>created ]
  75         [ st_mtimespec>> timespec>unix-time >>modified ]
  76         [ st_atimespec>> timespec>unix-time >>accessed ]
  77         [ st_uid>> >>uid ]
  78         [ st_gid>> >>gid ]
  79         [ st_dev>> >>dev ]
  80         [ st_ino>> >>ino ]
  81         [ st_nlink>> >>nlink ]
  82         [ st_rdev>> >>rdev ]
  83         [ st_blocks>> >>blocks ]
  84         [ st_blksize>> >>blocksize ]
  85         [ drop dup blocks>> standard-unix-block-size * >>size-on-disk ]
  86     } cleave ;
  87
  88 : n>file-type ( n -- type )
  89     S_IFMT bitand {
  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+ ] }
  97         [ drop +unknown+ ]
  98     } case ;
  99
 100 M: unix stat>type ( stat -- type )
 101     st_mode>> n>file-type ;
 102
 103 <PRIVATE
 104
 105 : stat-mode ( path -- mode )
 106     normalize-path file-status st_mode>> ;
 107
 108 : chmod-set-bit ( path mask ? -- )
 109     [ dup stat-mode ] 2dip
 110     [ bitor ] [ unmask ] if chmod io-error ;
 111
 112 GENERIC# file-mode? 1 ( obj mask -- ? )
 113
 114 M: integer file-mode? mask? ;
 115 M: string file-mode? [ stat-mode ] dip mask? ;
 116 M: file-info file-mode? [ permissions>> ] dip mask? ;
 117
 118 PRIVATE>
 119
 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
 135
 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? ;
 148
 149 : any-read? ( obj -- ? )
 150     { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
 151
 152 : any-write? ( obj -- ? )
 153     { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
 154
 155 : any-execute? ( obj -- ? )
 156     { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
 157
 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 ;
 170
 171 : set-file-permissions ( path n -- )
 172     [ normalize-path ] dip chmod io-error ;
 173
 174 : file-permissions ( path -- n )
 175     normalize-path file-info permissions>> ;
 176
 177 M: unix copy-file-and-info ( from to -- )
 178     [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
 179
 180 <PRIVATE
 181
 182 : timestamp>timeval ( timestamp -- timeval )
 183     unix-1970 time- duration>microseconds make-timeval ;
 184
 185 : timestamps>byte-array ( timestamps -- byte-array )
 186     [ [ timestamp>timeval ] [ \ timeval <struct> ] if* ] map
 187     \ timeval >struct-array ;
 188
 189 PRIVATE>
 190
 191 : set-file-times ( path timestamps -- )
 192     #! set access, write
 193     [ normalize-path ] dip
 194     timestamps>byte-array utimes io-error ;
 195
 196 : set-file-access-time ( path timestamp -- )
 197     f 2array set-file-times ;
 198
 199 : set-file-modified-time ( path timestamp -- )
 200     f swap 2array set-file-times ;
 201
 202 : set-file-ids ( path uid gid -- )
 203     [ normalize-path ] 2dip [ -1 or ] bi@ chown io-error ;
 204
 205 GENERIC: set-file-user ( path string/id -- )
 206
 207 GENERIC: set-file-group ( path string/id -- )
 208
 209 M: integer set-file-user ( path uid -- )
 210     f set-file-ids ;
 211
 212 M: string set-file-user ( path string -- )
 213     user-id f set-file-ids ;
 214
 215 M: integer set-file-group ( path gid -- )
 216     f swap set-file-ids ;
 217
 218 M: string set-file-group ( path string -- )
 219     group-id
 220     f swap set-file-ids ;
 221
 222 : file-user-id ( path -- uid )
 223     normalize-path file-info uid>> ;
 224
 225 : file-user-name ( path -- string )
 226     file-user-id user-name ;
 227
 228 : file-group-id ( path -- gid )
 229     normalize-path file-info gid>> ;
 230
 231 : file-group-name ( path -- string )
 232     file-group-id group-name ;
 233
 234 : ch>file-type ( ch -- type )
 235     {
 236         { CHAR: b [ +block-device+ ] }
 237         { CHAR: c [ +character-device+ ] }
 238         { CHAR: d [ +directory+ ] }
 239         { CHAR: l [ +symbolic-link+ ] }
 240         { CHAR: s [ +socket+ ] }
 241         { CHAR: p [ +fifo+ ] }
 242         { CHAR: - [ +regular-file+ ] }
 243         [ drop +unknown+ ]
 244     } case ;
 245
 246 : file-type>ch ( type -- ch )
 247     {
 248         { +block-device+ [ CHAR: b ] }
 249         { +character-device+ [ CHAR: c ] }
 250         { +directory+ [ CHAR: d ] }
 251         { +symbolic-link+ [ CHAR: l ] }
 252         { +socket+ [ CHAR: s ] }
 253         { +fifo+ [ CHAR: p ] }
 254         { +regular-file+ [ CHAR: - ] }
 255         [ drop CHAR: - ]
 256     } case ;
 257
 258 <PRIVATE
 259
 260 : file-type>executable ( directory-entry -- string )
 261     name>> any-execute? "*" "" ? ;
 262
 263 PRIVATE>
 264
 265 : file-type>trailing ( directory-entry -- string )
 266     dup type>>
 267     {
 268         { +directory+ [ drop "/" ] }
 269         { +symbolic-link+ [ drop "@" ] }
 270         { +fifo+ [ drop "|" ] }
 271         { +socket+ [ drop "=" ] }
 272         { +whiteout+ [ drop "%" ] }
 273         { +unknown+ [ file-type>executable ] }
 274         { +regular-file+ [ file-type>executable ] }
 275         [ drop file-type>executable ]
 276     } case ;