basis/io/files/info/info.factor

   1 ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators io.files io.files.types
   4 io.pathnames kernel math system vocabs ;
   5 IN: io.files.info
   6
   7 ! File info
   8 TUPLE: file-info-tuple type size size-on-disk permissions created modified
   9 accessed ;
  10
  11 HOOK: file-info os ( path -- info )
  12
  13 : ?file-info ( path -- info/f )
  14     dup exists? [ file-info ] [ drop f ] if ; inline
  15
  16 HOOK: link-info os ( path -- info )
  17
  18 : directory? ( file-info -- ? ) type>> +directory+ = ;
  19 : regular-file? ( file-info -- ? ) type>> +regular-file+ = ;
  20 : symbolic-link? ( file-info -- ? ) type>> +symbolic-link+ = ;
  21
  22 : sparse-file? ( file-info -- ? )
  23     [ size-on-disk>> ] [ size>> ] bi < ;
  24
  25 ! File systems
  26 HOOK: file-systems os ( -- array )
  27
  28 TUPLE: file-system-info-tuple device-name mount-point type
  29 available-space free-space used-space total-space ;
  30
  31 HOOK: file-system-info os ( path -- file-system-info )
  32
  33 HOOK: file-readable? os ( path -- ? )
  34 HOOK: file-writable? os ( path -- ? )
  35 HOOK: file-executable? os ( path -- ? )
  36
  37 : mount-points ( -- assoc )
  38     file-systems [ [ mount-point>> canonicalize-path-full ] keep ] H{ } map>assoc ;
  39
  40 : (find-mount-point-info) ( path assoc -- mtab-entry )
  41     [ resolve-symlinks canonicalize-path-full ] dip
  42     2dup at* [
  43         2nip
  44     ] [
  45         drop [ parent-directory ] dip
  46         (find-mount-point-info)
  47     ] if ;
  48
  49 : find-mount-point-info ( path -- file-system-info )
  50     mount-points (find-mount-point-info) ;
  51
  52 {
  53     { [ os unix? ] [ "io.files.info.unix" ] }
  54     { [ os windows? ] [ "io.files.info.windows" ] }
  55 } cond require