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 combinators.short-circuit
   4 io.files io.files.types io.pathnames kernel math strings system
   5 vocabs ;
   6 IN: io.files.info
   7
   8 ! File info
   9 TUPLE: file-info-tuple type size size-on-disk permissions created modified
  10 accessed ;
  11
  12 HOOK: file-info os ( path -- info )
  13
  14 : ?file-info ( path -- info/f )
  15     dup file-exists? [ file-info ] [ drop f ] if ;
  16
  17 HOOK: link-info os ( path -- info )
  18
  19 : ?link-info ( path -- info/f )
  20     dup file-exists? [ link-info ] [ drop f ] if ;
  21
  22 <PRIVATE
  23
  24 : >file-info ( path/info -- info )
  25     dup { [ string? ] [ pathname? ] } 1|| [ file-info ] when ;
  26
  27 PRIVATE>
  28
  29 : directory? ( path/info -- ? )
  30     >file-info type>> +directory+ = ;
  31
  32 : regular-file? ( path/info -- ? )
  33     >file-info type>> +regular-file+ = ;
  34
  35 : symbolic-link? ( path/info -- ? )
  36     >file-info type>> +symbolic-link+ = ;
  37
  38 : sparse-file? ( path/info -- ? )
  39     >file-info [ size-on-disk>> ] [ size>> ] bi < ;
  40
  41 ! File systems
  42 HOOK: file-systems os ( -- array )
  43
  44 TUPLE: file-system-info-tuple device-name mount-point type
  45 available-space free-space used-space total-space ;
  46
  47 HOOK: file-system-info os ( path -- file-system-info )
  48
  49 HOOK: file-readable? os ( path -- ? )
  50 HOOK: file-writable? os ( path -- ? )
  51 HOOK: file-executable? os ( path -- ? )
  52
  53 HOOK: mount-points os ( -- assoc )
  54
  55 M: object mount-points
  56     file-systems [ [ mount-point>> ] keep ] H{ } map>assoc ;
  57
  58 : (find-mount-point) ( path assoc -- object )
  59     [ resolve-symlinks canonicalize-path-full ] dip
  60     2dup at* [
  61         2nip
  62     ] [
  63         drop [ parent-directory ] dip (find-mount-point)
  64     ] if ;
  65
  66 : find-mount-point ( path -- object )
  67     mount-points (find-mount-point) ;
  68
  69 {
  70     { [ os unix? ] [ "io.files.info.unix" ] }
  71     { [ os windows? ] [ "io.files.info.windows" ] }
  72 } cond require