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

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs classes.struct combinators
   4 combinators.short-circuit continuations csv fry io.backend
   5 io.encodings.utf8 io.files.info io.files.info.unix io.pathnames kernel
   6 libc math math.parser sequences splitting strings system
   7 unix.statfs.linux unix.statvfs.linux ;
   8 FROM: csv => delimiter ;
   9 IN: io.files.info.unix.linux
  10
  11 TUPLE: linux-file-system-info < unix-file-system-info
  12 namelen ;
  13
  14 M: linux new-file-system-info linux-file-system-info new ;
  15
  16 M: linux file-system-statfs ( path -- statfs )
  17     \ statfs64 <struct> [ statfs64 io-error ] keep ;
  18
  19 M: linux statfs>file-system-info ( file-system-info statfs -- file-system-info' )
  20     {
  21         [ f_type>> >>type ]
  22         [ f_bsize>> >>block-size ]
  23         [ f_blocks>> >>blocks ]
  24         [ f_bfree>> >>blocks-free ]
  25         [ f_bavail>> >>blocks-available ]
  26         [ f_files>> >>files ]
  27         [ f_ffree>> >>files-free ]
  28         [ f_fsid>> >>id ]
  29         [ f_namelen>> >>namelen ]
  30         [ f_frsize>> >>preferred-block-size ]
  31         ! [ statfs64-f_spare >>spare ]
  32     } cleave ;
  33
  34 M: linux file-system-statvfs ( path -- statvfs )
  35     \ statvfs64 <struct> [ statvfs64 io-error ] keep ;
  36
  37 M: linux statvfs>file-system-info ( file-system-info statfs -- file-system-info' )
  38     {
  39         [ f_flag>> >>flags ]
  40         [ f_namemax>> >>name-max ]
  41     } cleave ;
  42
  43 TUPLE: mtab-entry file-system-name mount-point type options
  44 frequency pass-number ;
  45
  46 ! octal escape sequences, e.g. "/media/erg/4TB\\040E"
  47 : decode-mount-point ( string -- string' )
  48     dup "\\" split
  49     dup length 1 > [
  50         nip 1 cut
  51         [ 3 cut [ oct> 1string ] dip append ] map append concat
  52     ] [
  53         drop
  54     ] if ;
  55
  56 : mtab-csv>mtab-entry ( csv -- mtab-entry )
  57     [ mtab-entry new ] dip
  58     {
  59         [ first >>file-system-name ]
  60         [ second decode-mount-point >>mount-point ]
  61         [ third >>type ]
  62         [ fourth string>csv first >>options ]
  63         [ 4 swap ?nth [ 0 ] unless* >>frequency ]
  64         [ 5 swap ?nth [ 0 ] unless* >>pass-number ]
  65     } cleave ;
  66
  67 : parse-mtab ( -- array )
  68     CHAR: \s [ "/etc/mtab" utf8 file>csv ] with-delimiter
  69     [ mtab-csv>mtab-entry ] map ;
  70
  71 : (file-system-info) ( path -- file-system-info )
  72     [ new-file-system-info ] dip
  73     [ file-system-statfs statfs>file-system-info ]
  74     [ file-system-statvfs statvfs>file-system-info ] bi
  75     file-system-calculations ; inline
  76
  77 : mtab-entry>file-system-info ( mtab-entry -- file-system-info/f )
  78     '[
  79         _ [ mount-point>> (file-system-info) ] [ ] bi
  80         {
  81             [ file-system-name>> >>device-name ]
  82             [ mount-point>> >>mount-point ]
  83             [ type>> >>type ]
  84         } cleave
  85     ] [ { [ libc-error? ] [ errno>> EACCES = ] } 1&& ] ignore-error/f ;
  86
  87 M: linux mount-points
  88     parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc ;
  89
  90 M: linux file-systems
  91     parse-mtab [ mtab-entry>file-system-info ] map sift ;
  92
  93 M: linux file-system-info ( path -- file-system-info )
  94     normalize-path [ (file-system-info) ] [ ] bi
  95     find-mount-point
  96     {
  97         [ file-system-name>> >>device-name drop ]
  98         [ mount-point>> >>mount-point drop ]
  99         [ type>> >>type ]
 100     } 2cleave ;