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 io.backend
   6 unix unix.stat unix.time unix.users unix.groups ;
   7 IN: io.files.info.unix
   8
   9 TUPLE: unix-file-system-info < file-system-info
  10 block-size preferred-block-size
  11 blocks blocks-free blocks-available
  12 files files-free files-available
  13 name-max flags id ;
  14
  15 HOOK: new-file-system-info os ( --  file-system-info )
  16
  17 M: unix new-file-system-info ( -- ) unix-file-system-info new ;
  18
  19 HOOK: file-system-statfs os ( path -- statfs )
  20
  21 M: unix file-system-statfs drop f ;
  22
  23 HOOK: file-system-statvfs os ( path -- statvfs )
  24
  25 M: unix file-system-statvfs drop f ;
  26
  27 HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
  28
  29 M: unix statfs>file-system-info drop ;
  30
  31 HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
  32
  33 M: unix statvfs>file-system-info drop ;
  34
  35 : file-system-calculations ( file-system-info -- file-system-info' )
  36     dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space
  37     dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space
  38     dup [ blocks>> ] [ block-size>> ] bi * >>total-space
  39     dup [ total-space>> ] [ free-space>> ] bi - >>used-space ;
  40
  41 M: unix file-system-info
  42     normalize-path
  43     [ new-file-system-info ] dip
  44     [ file-system-statfs statfs>file-system-info ]
  45     [ file-system-statvfs statvfs>file-system-info ] bi
  46     file-system-calculations ;
  47
  48 TUPLE: unix-file-info < file-info uid gid dev ino
  49 nlink rdev blocks blocksize ;
  50
  51 HOOK: new-file-info os ( -- file-info )
  52
  53 HOOK: stat>file-info os ( stat -- file-info )
  54
  55 HOOK: stat>type os ( stat -- file-info )
  56
  57 M: unix file-info ( path -- info )
  58     normalize-path file-status stat>file-info ;
  59
  60 M: unix link-info ( path -- info )
  61     normalize-path link-status stat>file-info ;
  62
  63 M: unix new-file-info ( -- class ) unix-file-info new ;
  64
  65 M: unix stat>file-info ( stat -- file-info )
  66     [ new-file-info ] dip
  67     {
  68         [ stat>type >>type ]
  69         [ stat-st_size >>size ]
  70         [ stat-st_mode >>permissions ]
  71         [ stat-st_ctimespec timespec>unix-time >>created ]
  72         [ stat-st_mtimespec timespec>unix-time >>modified ]
  73         [ stat-st_atimespec timespec>unix-time >>accessed ]
  74         [ stat-st_uid >>uid ]
  75         [ stat-st_gid >>gid ]
  76         [ stat-st_dev >>dev ]
  77         [ stat-st_ino >>ino ]
  78         [ stat-st_nlink >>nlink ]
  79         [ stat-st_rdev >>rdev ]
  80         [ stat-st_blocks >>blocks ]
  81         [ stat-st_blksize >>blocksize ]
  82     } cleave ;
  83
  84 : n>file-type ( n -- type )
  85     S_IFMT bitand {
  86         { S_IFREG [ +regular-file+ ] }
  87         { S_IFDIR [ +directory+ ] }
  88         { S_IFCHR [ +character-device+ ] }
  89         { S_IFBLK [ +block-device+ ] }
  90         { S_IFIFO [ +fifo+ ] }
  91         { S_IFLNK [ +symbolic-link+ ] }
  92         { S_IFSOCK [ +socket+ ] }
  93         [ drop +unknown+ ]
  94     } case ;
  95
  96 M: unix stat>type ( stat -- type )
  97     stat-st_mode n>file-type ;
  98
  99 <PRIVATE
 100
 101 : stat-mode ( path -- mode )
 102     normalize-path file-status stat-st_mode ;
 103
 104 : chmod-set-bit ( path mask ? -- )
 105     [ dup stat-mode ] 2dip
 106     [ bitor ] [ unmask ] if chmod io-error ;
 107
 108 GENERIC# file-mode? 1 ( obj mask -- ? )
 109
 110 M: integer file-mode? mask? ;
 111 M: string file-mode? [ stat-mode ] dip mask? ;
 112 M: file-info file-mode? [ permissions>> ] dip mask? ;
 113
 114 PRIVATE>
 115
 116 : ch>file-type ( ch -- type )
 117     {
 118         { CHAR: b [ +block-device+ ] }
 119         { CHAR: c [ +character-device+ ] }
 120         { CHAR: d [ +directory+ ] }
 121         { CHAR: l [ +symbolic-link+ ] }
 122         { CHAR: s [ +socket+ ] }
 123         { CHAR: p [ +fifo+ ] }
 124         { CHAR: - [ +regular-file+ ] }
 125         [ drop +unknown+ ]
 126     } case ;
 127
 128 : file-type>ch ( type -- string )
 129     {
 130         { +block-device+ [ CHAR: b ] }
 131         { +character-device+ [ CHAR: c ] }
 132         { +directory+ [ CHAR: d ] }
 133         { +symbolic-link+ [ CHAR: l ] }
 134         { +socket+ [ CHAR: s ] }
 135         { +fifo+ [ CHAR: p ] }
 136         { +regular-file+ [ CHAR: - ] }
 137         [ drop CHAR: - ]
 138     } case ;
 139
 140 : UID           OCT: 0004000 ; inline
 141 : GID           OCT: 0002000 ; inline
 142 : STICKY        OCT: 0001000 ; inline
 143 : USER-ALL      OCT: 0000700 ; inline
 144 : USER-READ     OCT: 0000400 ; inline
 145 : USER-WRITE    OCT: 0000200 ; inline
 146 : USER-EXECUTE  OCT: 0000100 ; inline
 147 : GROUP-ALL     OCT: 0000070 ; inline
 148 : GROUP-READ    OCT: 0000040 ; inline
 149 : GROUP-WRITE   OCT: 0000020 ; inline
 150 : GROUP-EXECUTE OCT: 0000010 ; inline
 151 : OTHER-ALL     OCT: 0000007 ; inline
 152 : OTHER-READ    OCT: 0000004 ; inline
 153 : OTHER-WRITE   OCT: 0000002 ; inline
 154 : OTHER-EXECUTE OCT: 0000001 ; inline
 155
 156 : uid? ( obj -- ? ) UID file-mode? ;
 157 : gid? ( obj -- ? ) GID file-mode? ;
 158 : sticky? ( obj -- ? ) STICKY file-mode? ;
 159 : user-read? ( obj -- ? ) USER-READ file-mode? ;
 160 : user-write? ( obj -- ? ) USER-WRITE file-mode? ;
 161 : user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
 162 : group-read? ( obj -- ? ) GROUP-READ file-mode? ;
 163 : group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
 164 : group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
 165 : other-read? ( obj -- ? ) OTHER-READ file-mode? ;
 166 : other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
 167 : other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
 168
 169 : any-read? ( obj -- ? )
 170     { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
 171
 172 : any-write? ( obj -- ? )
 173     { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
 174
 175 : any-execute? ( obj -- ? )
 176     { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
 177
 178 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
 179 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
 180 : set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
 181 : set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
 182 : set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
 183 : set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
 184 : set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
 185 : set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
 186 : set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
 187 : set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
 188 : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
 189 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
 190
 191 : set-file-permissions ( path n -- )
 192     [ normalize-path ] dip chmod io-error ;
 193
 194 : file-permissions ( path -- n )
 195     normalize-path file-info permissions>> ;
 196
 197 <PRIVATE
 198
 199 : make-timeval-array ( array -- byte-array )
 200     [ [ "timeval" <c-object> ] unless* ] map concat ;
 201
 202 : timestamp>timeval ( timestamp -- timeval )
 203     unix-1970 time- duration>microseconds make-timeval ;
 204
 205 : timestamps>byte-array ( timestamps -- byte-array )
 206     [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
 207
 208 PRIVATE>
 209
 210 : set-file-times ( path timestamps -- )
 211     #! set access, write
 212     [ normalize-path ] dip
 213     timestamps>byte-array utimes io-error ;
 214
 215 : set-file-access-time ( path timestamp -- )
 216     f 2array set-file-times ;
 217
 218 : set-file-modified-time ( path timestamp -- )
 219     f swap 2array set-file-times ;
 220
 221 : set-file-ids ( path uid gid -- )
 222     [ normalize-path ] 2dip
 223     [ [ -1 ] unless* ] bi@ chown io-error ;
 224
 225 GENERIC: set-file-user ( path string/id -- )
 226
 227 GENERIC: set-file-group ( path string/id -- )
 228
 229 M: integer set-file-user ( path uid -- )
 230     f set-file-ids ;
 231
 232 M: string set-file-user ( path string -- )
 233     user-id f set-file-ids ;
 234
 235 M: integer set-file-group ( path gid -- )
 236     f swap set-file-ids ;
 237
 238 M: string set-file-group ( path string -- )
 239     group-id
 240     f swap set-file-ids ;
 241
 242 : file-user-id ( path -- uid )
 243     normalize-path file-info uid>> ;
 244
 245 : file-username ( path -- string )
 246     file-user-id username ;
 247
 248 : file-group-id ( path -- gid )
 249     normalize-path file-info gid>> ;
 250
 251 : file-group-name ( path -- string )
 252     file-group-id group-name ;