basis/tools/files/files.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators io io.files io.files.info
   4 io.directories kernel math.parser sequences system vocabs.loader
   5 calendar math fry prettyprint ;
   6 IN: tools.files
   7
   8 <PRIVATE
   9
  10 : ls-time ( timestamp -- string )
  11     [ hour>> ] [ minute>> ] bi
  12     [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
  13
  14 : ls-timestamp ( timestamp -- string )
  15     [ month>> month-abbreviation ]
  16     [ day>> number>string 2 CHAR: \s pad-left ]
  17     [
  18         dup year>> dup now year>> =
  19         [ drop ls-time ] [ nip number>string ] if
  20         5 CHAR: \s pad-left
  21     ] tri 3array " " join ;
  22
  23 : read>string ( ? -- string ) "r" "-" ? ; inline
  24
  25 : write>string ( ? -- string ) "w" "-" ? ; inline
  26
  27 : execute>string ( ? -- string ) "x" "-" ? ; inline
  28
  29 HOOK: (directory.) os ( path -- lines )
  30
  31 PRIVATE>
  32
  33 : directory. ( path -- )
  34     [ (directory.) ] with-directory-files [ print ] each ;
  35
  36 SYMBOLS: device-name mount-point type
  37 available-space free-space used-space total-space
  38 percent-used percent-free ;
  39
  40 : percent ( real -- integer ) 100 * >integer ; inline
  41
  42 : file-system-spec ( file-system-info obj -- str )
  43     {
  44         { device-name [ device-name>> [ "" ] unless* ] }
  45         { mount-point [ mount-point>> [ "" ] unless* ] }
  46         { type [ type>> [ "" ] unless* ] }
  47         { available-space [ available-space>> [ 0 ] unless* ] }
  48         { free-space [ free-space>> [ 0 ] unless* ] }
  49         { used-space [ used-space>> [ 0 ] unless* ] }
  50         { total-space [ total-space>> [ 0 ] unless* ] }
  51         { percent-used [
  52             [ used-space>> ] [ total-space>> ] bi
  53             [ [ 0 ] unless* ] bi@ dup 0 =
  54             [ 2drop 0 ] [ / percent ] if
  55         ] }
  56     } case ;
  57
  58 : file-systems-info ( spec -- seq )
  59     file-systems swap '[ _ [ file-system-spec ] with map ] map ;
  60
  61 : print-file-systems ( spec -- )
  62     [ file-systems-info ]
  63     [ [ unparse ] map ] bi prefix simple-table. ;
  64
  65 : file-systems. ( -- )
  66     { device-name free-space used-space total-space percent-used mount-point }
  67     print-file-systems ;
  68
  69 {
  70     { [ os unix? ] [ "tools.files.unix" ] }
  71     { [ os windows? ] [ "tools.files.windows" ] }
  72 } cond require