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