basis/io/unix/files/files.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   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 ;
   8
   9 IN: io.unix.files
  10
  11 M: unix cwd ( -- path )
  12     MAXPATHLEN [ <byte-array> ] keep getcwd
  13     [ (io-error) ] unless* ;
  14
  15 M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
  16
  17 : read-flags O_RDONLY ; inline
  18
  19 : open-read ( path -- fd ) O_RDONLY file-mode open-file ;
  20
  21 M: unix (file-reader) ( path -- stream )
  22     open-read <fd> init-fd <input-port> ;
  23
  24 : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
  25
  26 : open-write ( path -- fd )
  27     write-flags file-mode open-file ;
  28
  29 M: unix (file-writer) ( path -- stream )
  30     open-write <fd> init-fd <output-port> ;
  31
  32 : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
  33
  34 : open-append ( path -- fd )
  35     [
  36         append-flags file-mode open-file |dispose
  37         dup 0 SEEK_END lseek io-error
  38     ] with-destructors ;
  39
  40 M: unix (file-appender) ( path -- stream )
  41     open-append <fd> init-fd <output-port> ;
  42
  43 : touch-mode ( -- n )
  44     { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
  45
  46 M: unix touch-file ( path -- )
  47     normalize-path
  48     dup exists? [ touch ] [
  49         touch-mode file-mode open-file close-file
  50     ] if ;
  51
  52 M: unix move-file ( from to -- )
  53     [ normalize-path ] bi@ rename io-error ;
  54
  55 M: unix delete-file ( path -- ) normalize-path unlink-file ;
  56
  57 M: unix make-directory ( path -- )
  58     normalize-path OCT: 777 mkdir io-error ;
  59
  60 M: unix delete-directory ( path -- )
  61     normalize-path rmdir io-error ;
  62
  63 : (copy-file) ( from to -- )
  64     dup parent-directory make-directories
  65     binary <file-writer> [
  66         swap binary <file-reader> [
  67             swap stream-copy
  68         ] with-disposal
  69     ] with-disposal ;
  70
  71 M: unix copy-file ( from to -- )
  72     [ normalize-path ] bi@
  73     [ (copy-file) ]
  74     [ swap file-info permissions>> chmod io-error ]
  75     2bi ;
  76
  77 : stat>type ( stat -- type )
  78     stat-st_mode S_IFMT bitand {
  79         { S_IFREG [ +regular-file+ ] }
  80         { S_IFDIR [ +directory+ ] }
  81         { S_IFCHR [ +character-device+ ] }
  82         { S_IFBLK [ +block-device+ ] }
  83         { S_IFIFO [ +fifo+ ] }
  84         { S_IFLNK [ +symbolic-link+ ] }
  85         { S_IFSOCK [ +socket+ ] }
  86         [ drop +unknown+ ]
  87     } case ;
  88
  89 : stat>file-info ( stat -- info )
  90     {
  91         [ stat>type ]
  92         [ stat-st_size ]
  93         [ stat-st_mode ]
  94         [ stat-st_mtim timespec-sec seconds unix-1970 time+ ]
  95     } cleave
  96     \ file-info boa ;
  97
  98 M: unix file-info ( path -- info )
  99     normalize-path file-status stat>file-info ;
 100
 101 M: unix link-info ( path -- info )
 102     normalize-path link-status stat>file-info ;
 103
 104 M: unix make-link ( path1 path2 -- )
 105     normalize-path symlink io-error ;
 106
 107 M: unix read-link ( path -- path' )
 108    normalize-path read-symbolic-link ;