basis/io/unix/files/files.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: io.backend io.ports io.unix.backend io.files io
   4 unix unix.stat unix.time kernel math continuations
   5 math.bitwise byte-arrays alien combinators calendar
   6 io.encodings.binary accessors sequences strings system
   7 io.files.private destructors vocabs.loader calendar.unix
   8 unix.stat alien.c-types arrays unix.users unix.groups
   9 environment fry io.encodings.utf8 alien.strings
  10 combinators.short-circuit ;
  11 IN: io.unix.files
  12
  13 M: unix cwd ( -- path )
  14     MAXPATHLEN [ <byte-array> ] keep getcwd
  15     [ (io-error) ] unless* ;
  16
  17 M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
  18
  19 : read-flags O_RDONLY ; inline
  20
  21 : open-read ( path -- fd ) O_RDONLY file-mode open-file ;
  22
  23 M: unix (file-reader) ( path -- stream )
  24     open-read <fd> init-fd <input-port> ;
  25
  26 : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
  27
  28 : open-write ( path -- fd )
  29     write-flags file-mode open-file ;
  30
  31 M: unix (file-writer) ( path -- stream )
  32     open-write <fd> init-fd <output-port> ;
  33
  34 : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
  35
  36 : open-append ( path -- fd )
  37     [
  38         append-flags file-mode open-file |dispose
  39         dup 0 SEEK_END lseek io-error
  40     ] with-destructors ;
  41
  42 M: unix (file-appender) ( path -- stream )
  43     open-append <fd> init-fd <output-port> ;
  44
  45 : touch-mode ( -- n )
  46     { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
  47
  48 M: unix touch-file ( path -- )
  49     normalize-path
  50     dup exists? [ touch ] [
  51         touch-mode file-mode open-file close-file
  52     ] if ;
  53
  54 M: unix move-file ( from to -- )
  55     [ normalize-path ] bi@ rename io-error ;
  56
  57 M: unix delete-file ( path -- ) normalize-path unlink-file ;
  58
  59 M: unix make-directory ( path -- )
  60     normalize-path OCT: 777 mkdir io-error ;
  61
  62 M: unix delete-directory ( path -- )
  63     normalize-path rmdir io-error ;
  64
  65 : (copy-file) ( from to -- )
  66     dup parent-directory make-directories
  67     binary <file-writer> [
  68         swap binary <file-reader> [
  69             swap stream-copy
  70         ] with-disposal
  71     ] with-disposal ;
  72
  73 M: unix copy-file ( from to -- )
  74     [ normalize-path ] bi@
  75     [ (copy-file) ]
  76     [ swap file-info permissions>> chmod io-error ]
  77     2bi ;
  78
  79 TUPLE: unix-file-system-info < file-system-info
  80 block-size preferred-block-size
  81 blocks blocks-free blocks-available
  82 files files-free files-available
  83 name-max flags id ;
  84
  85 HOOK: new-file-system-info os ( --  file-system-info )
  86
  87 M: unix new-file-system-info ( -- ) unix-file-system-info new ;
  88
  89 HOOK: file-system-statfs os ( path -- statfs )
  90
  91 M: unix file-system-statfs drop f ;
  92
  93 HOOK: file-system-statvfs os ( path -- statvfs )
  94
  95 M: unix file-system-statvfs drop f ;
  96
  97 HOOK: statfs>file-system-info os ( file-system-info statfs -- file-system-info' )
  98
  99 M: unix statfs>file-system-info drop ;
 100
 101 HOOK: statvfs>file-system-info os ( file-system-info statvfs -- file-system-info' )
 102
 103 M: unix statvfs>file-system-info drop ;
 104
 105 : file-system-calculations ( file-system-info -- file-system-info' )
 106     {
 107         [ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space drop ]
 108         [ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ]
 109         [ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
 110         [ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
 111         [ ]
 112     } cleave ;
 113
 114 M: unix file-system-info
 115     normalize-path
 116     [ new-file-system-info ] dip
 117     [ file-system-statfs statfs>file-system-info ]
 118     [ file-system-statvfs statvfs>file-system-info ] bi
 119     file-system-calculations ;
 120
 121 os {
 122     { linux   [ "io.unix.files.linux"   require ] }
 123     { macosx  [ "io.unix.files.macosx"  require ] }
 124     { freebsd [ "io.unix.files.freebsd" require ] }
 125     { netbsd  [ "io.unix.files.netbsd"  require ] }
 126     { openbsd [ "io.unix.files.openbsd" require ] }
 127 } case
 128
 129 TUPLE: unix-file-info < file-info uid gid dev ino
 130 nlink rdev blocks blocksize ;
 131
 132 HOOK: new-file-info os ( -- file-info )
 133
 134 HOOK: stat>file-info os ( stat -- file-info )
 135
 136 HOOK: stat>type os ( stat -- file-info )
 137
 138 M: unix file-info ( path -- info )
 139     normalize-path file-status stat>file-info ;
 140
 141 M: unix link-info ( path -- info )
 142     normalize-path link-status stat>file-info ;
 143
 144 M: unix make-link ( path1 path2 -- )
 145     normalize-path symlink io-error ;
 146
 147 M: unix read-link ( path -- path' )
 148    normalize-path read-symbolic-link ;
 149
 150 M: unix new-file-info ( -- class ) unix-file-info new ;
 151
 152 M: unix stat>file-info ( stat -- file-info )
 153     [ new-file-info ] dip
 154     {
 155         [ stat>type >>type ]
 156         [ stat-st_size >>size ]
 157         [ stat-st_mode >>permissions ]
 158         [ stat-st_ctimespec timespec>unix-time >>created ]
 159         [ stat-st_mtimespec timespec>unix-time >>modified ]
 160         [ stat-st_atimespec timespec>unix-time >>accessed ]
 161         [ stat-st_uid >>uid ]
 162         [ stat-st_gid >>gid ]
 163         [ stat-st_dev >>dev ]
 164         [ stat-st_ino >>ino ]
 165         [ stat-st_nlink >>nlink ]
 166         [ stat-st_rdev >>rdev ]
 167         [ stat-st_blocks >>blocks ]
 168         [ stat-st_blksize >>blocksize ]
 169     } cleave ;
 170
 171 : n>file-type ( n -- type )
 172     S_IFMT bitand {
 173         { S_IFREG [ +regular-file+ ] }
 174         { S_IFDIR [ +directory+ ] }
 175         { S_IFCHR [ +character-device+ ] }
 176         { S_IFBLK [ +block-device+ ] }
 177         { S_IFIFO [ +fifo+ ] }
 178         { S_IFLNK [ +symbolic-link+ ] }
 179         { S_IFSOCK [ +socket+ ] }
 180         [ drop +unknown+ ]
 181     } case ;
 182
 183 M: unix stat>type ( stat -- type )
 184     stat-st_mode n>file-type ;
 185
 186 ! Linux has no extra fields in its stat struct
 187 os {
 188     { macosx  [ "io.unix.files.bsd" require ] }
 189     { netbsd  [ "io.unix.files.bsd" require ] }
 190     { openbsd  [ "io.unix.files.bsd" require ] }
 191     { freebsd  [ "io.unix.files.bsd" require ] }
 192     { linux [ ] }
 193 } case
 194
 195 : with-unix-directory ( path quot -- )
 196     [ opendir dup [ (io-error) ] unless ] dip
 197     dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
 198
 199 : find-next-file ( DIR* -- byte-array )
 200     "dirent" <c-object>
 201     f <void*>
 202     [ readdir_r 0 = [ (io-error) ] unless ] 2keep
 203     *void* [ drop f ] unless ;
 204
 205 M: unix >directory-entry ( byte-array -- directory-entry )
 206     [ dirent-d_name utf8 alien>string ]
 207     [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
 208
 209 M: unix (directory-entries) ( path -- seq )
 210     [
 211         '[ _ find-next-file dup ]
 212         [ >directory-entry ]
 213         [ drop ] produce
 214     ] with-unix-directory ;
 215
 216 <PRIVATE
 217
 218 : stat-mode ( path -- mode )
 219     normalize-path file-status stat-st_mode ;
 220
 221 : chmod-set-bit ( path mask ? -- )
 222     [ dup stat-mode ] 2dip
 223     [ bitor ] [ unmask ] if chmod io-error ;
 224
 225 GENERIC# file-mode? 1 ( obj mask -- ? )
 226
 227 M: integer file-mode? mask? ;
 228 M: string file-mode? [ stat-mode ] dip mask? ;
 229 M: file-info file-mode? [ permissions>> ] dip mask? ;
 230
 231 PRIVATE>
 232
 233 : ch>file-type ( ch -- type )
 234     {
 235         { CHAR: b [ +block-device+ ] }
 236         { CHAR: c [ +character-device+ ] }
 237         { CHAR: d [ +directory+ ] }
 238         { CHAR: l [ +symbolic-link+ ] }
 239         { CHAR: s [ +socket+ ] }
 240         { CHAR: p [ +fifo+ ] }
 241         { CHAR: - [ +regular-file+ ] }
 242         [ drop +unknown+ ]
 243     } case ;
 244
 245 : file-type>ch ( type -- string )
 246     {
 247         { +block-device+ [ CHAR: b ] }
 248         { +character-device+ [ CHAR: c ] }
 249         { +directory+ [ CHAR: d ] }
 250         { +symbolic-link+ [ CHAR: l ] }
 251         { +socket+ [ CHAR: s ] }
 252         { +fifo+ [ CHAR: p ] }
 253         { +regular-file+ [ CHAR: - ] }
 254         [ drop CHAR: - ]
 255     } case ;
 256
 257 : UID           OCT: 0004000 ; inline
 258 : GID           OCT: 0002000 ; inline
 259 : STICKY        OCT: 0001000 ; inline
 260 : USER-ALL      OCT: 0000700 ; inline
 261 : USER-READ     OCT: 0000400 ; inline
 262 : USER-WRITE    OCT: 0000200 ; inline
 263 : USER-EXECUTE  OCT: 0000100 ; inline
 264 : GROUP-ALL     OCT: 0000070 ; inline
 265 : GROUP-READ    OCT: 0000040 ; inline
 266 : GROUP-WRITE   OCT: 0000020 ; inline
 267 : GROUP-EXECUTE OCT: 0000010 ; inline
 268 : OTHER-ALL     OCT: 0000007 ; inline
 269 : OTHER-READ    OCT: 0000004 ; inline
 270 : OTHER-WRITE   OCT: 0000002 ; inline
 271 : OTHER-EXECUTE OCT: 0000001 ; inline
 272
 273 : uid? ( obj -- ? ) UID file-mode? ;
 274 : gid? ( obj -- ? ) GID file-mode? ;
 275 : sticky? ( obj -- ? ) STICKY file-mode? ;
 276 : user-read? ( obj -- ? ) USER-READ file-mode? ;
 277 : user-write? ( obj -- ? ) USER-WRITE file-mode? ;
 278 : user-execute? ( obj -- ? ) USER-EXECUTE file-mode? ;
 279 : group-read? ( obj -- ? ) GROUP-READ file-mode? ;
 280 : group-write? ( obj -- ? ) GROUP-WRITE file-mode? ;
 281 : group-execute? ( obj -- ? ) GROUP-EXECUTE file-mode? ;
 282 : other-read? ( obj -- ? ) OTHER-READ file-mode? ;
 283 : other-write? ( obj -- ? ) OTHER-WRITE file-mode? ;
 284 : other-execute? ( obj -- ? ) OTHER-EXECUTE file-mode? ;
 285
 286 : any-read? ( obj -- ? )
 287     { [ user-read? ] [ group-read? ] [ other-read? ] } 1|| ;
 288
 289 : any-write? ( obj -- ? )
 290     { [ user-write? ] [ group-write? ] [ other-write? ] } 1|| ;
 291
 292 : any-execute? ( obj -- ? )
 293     { [ user-execute? ] [ group-execute? ] [ other-execute? ] } 1|| ;
 294
 295 : set-uid ( path ? -- ) UID swap chmod-set-bit ;
 296 : set-gid ( path ? -- ) GID swap chmod-set-bit ;
 297 : set-sticky ( path ? -- ) STICKY swap chmod-set-bit ;
 298 : set-user-read ( path ? -- ) USER-READ swap chmod-set-bit ;
 299 : set-user-write ( path ? -- ) USER-WRITE swap chmod-set-bit ;
 300 : set-user-execute ( path ? -- ) USER-EXECUTE swap chmod-set-bit ;
 301 : set-group-read ( path ? -- ) GROUP-READ swap chmod-set-bit ;
 302 : set-group-write ( path ? -- ) GROUP-WRITE swap chmod-set-bit ;
 303 : set-group-execute ( path ? -- ) GROUP-EXECUTE swap chmod-set-bit ;
 304 : set-other-read ( path ? -- ) OTHER-READ swap chmod-set-bit ;
 305 : set-other-write ( path ? -- ) OTHER-WRITE swap chmod-set-bit ;
 306 : set-other-execute ( path ? -- ) OTHER-EXECUTE swap chmod-set-bit ;
 307
 308 : set-file-permissions ( path n -- )
 309     [ normalize-path ] dip chmod io-error ;
 310
 311 : file-permissions ( path -- n )
 312     normalize-path file-info permissions>> ;
 313
 314 <PRIVATE
 315
 316 : make-timeval-array ( array -- byte-array )
 317     [ [ "timeval" <c-object> ] unless* ] map concat ;
 318
 319 : timestamp>timeval ( timestamp -- timeval )
 320     unix-1970 time- duration>microseconds make-timeval ;
 321
 322 : timestamps>byte-array ( timestamps -- byte-array )
 323     [ dup [ timestamp>timeval ] when ] map make-timeval-array ;
 324
 325 PRIVATE>
 326
 327 : set-file-times ( path timestamps -- )
 328     #! set access, write
 329     [ normalize-path ] dip
 330     timestamps>byte-array utimes io-error ;
 331
 332 : set-file-access-time ( path timestamp -- )
 333     f 2array set-file-times ;
 334
 335 : set-file-modified-time ( path timestamp -- )
 336     f swap 2array set-file-times ;
 337
 338 : set-file-ids ( path uid gid -- )
 339     [ normalize-path ] 2dip
 340     [ [ -1 ] unless* ] bi@ chown io-error ;
 341
 342 GENERIC: set-file-user ( path string/id -- )
 343
 344 GENERIC: set-file-group ( path string/id -- )
 345
 346 M: integer set-file-user ( path uid -- )
 347     f set-file-ids ;
 348
 349 M: string set-file-user ( path string -- )
 350     user-id f set-file-ids ;
 351
 352 M: integer set-file-group ( path gid -- )
 353     f swap set-file-ids ;
 354
 355 M: string set-file-group ( path string -- )
 356     group-id
 357     f swap set-file-ids ;
 358
 359 : file-user-id ( path -- uid )
 360     normalize-path file-info uid>> ;
 361
 362 : file-username ( path -- string )
 363     file-user-id username ;
 364
 365 : file-group-id ( path -- gid )
 366     normalize-path file-info gid>> ;
 367
 368 : file-group-name ( path -- string )
 369     file-group-id group-name ;
 370
 371 M: unix home "HOME" os-env ;