basis/tools/files/files.factor

   1 ! Copyright (C) 2008, 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays calendar combinators fry io io.directories
   4 io.files.info kernel math math.parser prettyprint sequences system
   5 vocabs sorting.slots calendar.format ;
   6 IN: tools.files
   7
   8 <PRIVATE
   9
  10 : dir-or-size ( file-info -- str )
  11     dup directory? [
  12         drop "<DIR>" 20 CHAR: \s pad-tail
  13     ] [
  14         size>> number>string 20 CHAR: \s pad-head
  15     ] if ;
  16
  17 : listing-time ( timestamp -- string )
  18     [ hour>> ] [ minute>> ] bi
  19     [ number>string 2 CHAR: 0 pad-head ] bi@ ":" glue ;
  20
  21 : listing-date ( timestamp -- string )
  22     [ month>> month-abbreviation ]
  23     [ day>> number>string 2 CHAR: \s pad-head ]
  24     [
  25         dup year>> dup now year>> =
  26         [ drop listing-time ] [ nip number>string ] if
  27         5 CHAR: \s pad-head
  28     ] tri 3array " " join ;
  29
  30 : read>string ( ? -- string ) "r" "-" ? ; inline
  31
  32 : write>string ( ? -- string ) "w" "-" ? ; inline
  33
  34 : execute>string ( ? -- string ) "x" "-" ? ; inline
  35
  36 PRIVATE>
  37
  38 SYMBOLS: +file-name+ +file-name/type+ +permissions+ +file-type+
  39 +nlinks+ +file-size+ +file-date+ +file-time+ +file-datetime+
  40 +uid+ +gid+ +user+ +group+ +link-target+ +unix-datetime+
  41 +directory-or-size+ ;
  42
  43 TUPLE: listing-tool path specs sort ;
  44
  45 TUPLE: file-listing directory-entry file-info ;
  46
  47 C: <file-listing> file-listing
  48
  49 : <listing-tool> ( path -- listing-tool )
  50     listing-tool new
  51         swap >>path
  52         { +file-name+ } >>specs ;
  53
  54 : list-slow? ( listing-tool -- ? )
  55     specs>> { +file-name+ } sequence= not ;
  56
  57 ERROR: unknown-file-spec symbol ;
  58
  59 HOOK: file-spec>string os ( file-listing spec -- string )
  60
  61 M: object file-spec>string ( file-listing spec -- string )
  62     {
  63         { +file-name+ [ directory-entry>> name>> ] }
  64         { +directory-or-size+ [ file-info>> dir-or-size ] }
  65         { +file-size+ [ file-info>> size>> number>string ] }
  66         { +file-date+ [ file-info>> modified>> listing-date ] }
  67         { +file-time+ [ file-info>> modified>> listing-time ] }
  68         { +file-datetime+ [ file-info>> modified>> timestamp>ymdhms ] }
  69         [ unknown-file-spec ]
  70     } case ;
  71
  72 : list-files-fast ( listing-tool -- array )
  73     path>> [ [ name>> 1array ] map ] with-directory-entries ; inline
  74
  75 : list-files-slow ( listing-tool -- array )
  76     [ path>> ] [ sort>> ] [ specs>> ] tri '[
  77         [ dup name>> link-info file-listing boa ] map
  78         _ [ sort-by ] when*
  79         [ _ [ file-spec>string ] with map ] map
  80     ] with-directory-entries ; inline
  81
  82 : list-files ( listing-tool -- array )
  83     dup list-slow? [ list-files-slow ] [ list-files-fast ] if ; inline
  84
  85 HOOK: (directory.) os ( path -- lines )
  86
  87 : directory. ( path -- ) (directory.) simple-table. ;
  88
  89 SYMBOLS: +device-name+ +mount-point+ +type+
  90 +available-space+ +free-space+ +used-space+ +total-space+
  91 +percent-used+ +percent-free+ ;
  92
  93 : percent ( real -- integer ) 100 * >integer ; inline
  94
  95 : file-system-spec ( file-system-info obj -- str )
  96     {
  97         { +device-name+ [ device-name>> "" or ] }
  98         { +mount-point+ [ mount-point>> "" or ] }
  99         { +type+ [ type>> "" or ] }
 100         { +available-space+ [ available-space>> 0 or ] }
 101         { +free-space+ [ free-space>> 0 or ] }
 102         { +used-space+ [ used-space>> 0 or ] }
 103         { +total-space+ [ total-space>> 0 or ] }
 104         { +percent-used+ [
 105             [ used-space>> ] [ total-space>> ] bi
 106             [ 0 or ] bi@ dup 0 =
 107             [ 2drop 0 ] [ / percent ] if
 108         ] }
 109     } case ;
 110
 111 : file-systems-info ( spec -- seq )
 112     file-systems swap '[ _ [ file-system-spec ] with map ] map ;
 113
 114 : print-file-systems ( spec -- )
 115     [ file-systems-info ]
 116     [ [ unparse ] map ] bi prefix simple-table. ;
 117
 118 CONSTANT: default-file-systems-spec
 119     {
 120         +device-name+ +available-space+ +free-space+ +used-space+
 121         +total-space+ +percent-used+ +mount-point+
 122     }
 123
 124 : file-systems. ( -- )
 125     default-file-systems-spec print-file-systems ;
 126
 127 {
 128     { [ os unix? ] [ "tools.files.unix" ] }
 129     { [ os windows? ] [ "tools.files.windows" ] }
 130 } cond require