basis/tools/files/files.factor

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