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 alien.c-types alien.syntax combinators csv
   4 io.backend io.encodings.utf8 io.files io.files.info
   5 io.files.unix libc libc.linux kernel math.order namespaces sequences
   6 sorting system unix unix.statfs.linux unix.statvfs.linux io.files.links
   7 arrays io.files.info.unix assocs io.pathnames unix.types
   8 classes.struct ;
   9 FROM: csv => delimiter ;
  10 IN: io.files.info.unix.linux
  11
  12 TUPLE: linux-file-system-info < unix-file-system-info
  13 namelen ;
  14
  15 M: linux new-file-system-info linux-file-system-info new ;
  16
  17 M: linux file-system-statfs ( path -- statfs )
  18     \ statfs64 <struct> [ statfs64 io-error ] keep ;
  19
  20 M: linux statfs>file-system-info ( file-system-info statfs -- file-system-info' )
  21     {
  22         [ f_type>> >>type ]
  23         [ f_bsize>> >>block-size ]
  24         [ f_blocks>> >>blocks ]
  25         [ f_bfree>> >>blocks-free ]
  26         [ f_bavail>> >>blocks-available ]
  27         [ f_files>> >>files ]
  28         [ f_ffree>> >>files-free ]
  29         [ f_fsid>> >>id ]
  30         [ f_namelen>> >>namelen ]
  31         [ f_frsize>> >>preferred-block-size ]
  32         ! [ statfs64-f_spare >>spare ]
  33     } cleave ;
  34
  35 M: linux file-system-statvfs ( path -- statvfs )
  36     \ statvfs64 <struct> [ statvfs64 io-error ] keep ;
  37
  38 M: linux statvfs>file-system-info ( file-system-info statfs -- file-system-info' )
  39     {
  40         [ f_flag>> >>flags ]
  41         [ f_namemax>> >>name-max ]
  42     } cleave ;
  43
  44 TUPLE: mtab-entry file-system-name mount-point type options
  45 frequency pass-number ;
  46
  47 : mtab-csv>mtab-entry ( csv -- mtab-entry )
  48     [ mtab-entry new ] dip
  49     {
  50         [ first >>file-system-name ]
  51         [ second >>mount-point ]
  52         [ third >>type ]
  53         [ fourth string>csv first >>options ]
  54         [ 4 swap ?nth [ 0 ] unless* >>frequency ]
  55         [ 5 swap ?nth [ 0 ] unless* >>pass-number ]
  56     } cleave ;
  57
  58 : parse-mtab ( -- array )
  59     CHAR: \s [ "/etc/mtab" utf8 file>csv ] with-delimiter
  60     [ mtab-csv>mtab-entry ] map ;
  61
  62 M: linux file-systems
  63     parse-mtab [
  64         [ mount-point>> file-system-info ] keep
  65         {
  66             [ file-system-name>> >>device-name ]
  67             [ mount-point>> >>mount-point ]
  68             [ type>> >>type ]
  69         } cleave
  70     ] map ;
  71
  72 : (find-mount-point) ( path mtab-paths -- mtab-entry )
  73     2dup at* [
  74         2nip
  75     ] [
  76         drop [ parent-directory ] dip (find-mount-point)
  77     ] if ;
  78
  79 : find-mount-point ( path -- mtab-entry )
  80     resolve-symlinks
  81     parse-mtab [ [ mount-point>> ] keep ] H{ } map>assoc (find-mount-point) ;
  82
  83 ERROR: file-system-not-found ;
  84
  85 M: linux file-system-info ( path -- file-system-info )
  86     normalize-path
  87     [
  88         [ new-file-system-info ] dip
  89         [ file-system-statfs statfs>file-system-info ]
  90         [ file-system-statvfs statvfs>file-system-info ] bi
  91         file-system-calculations
  92     ] keep
  93     find-mount-point
  94     {
  95         [ file-system-name>> >>device-name drop ]
  96         [ mount-point>> >>mount-point drop ]
  97         [ type>> >>type ]
  98     } 2cleave ;