core/io/files/files.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov, Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: io.backend io.files.private io hashtables kernel
   4 kernel.private math memory namespaces sequences strings assocs
   5 arrays definitions system combinators splitting sbufs
   6 continuations destructors io.encodings io.encodings.binary init
   7 accessors math.order ;
   8 IN: io.files
   9
  10 HOOK: (file-reader) io-backend ( path -- stream )
  11
  12 HOOK: (file-writer) io-backend ( path -- stream )
  13
  14 HOOK: (file-appender) io-backend ( path -- stream )
  15
  16 : <file-reader> ( path encoding -- stream )
  17     swap normalize-path (file-reader) swap <decoder> ;
  18
  19 : <file-writer> ( path encoding -- stream )
  20     swap normalize-path (file-writer) swap <encoder> ;
  21
  22 : <file-appender> ( path encoding -- stream )
  23     swap normalize-path (file-appender) swap <encoder> ;
  24
  25 : file-lines ( path encoding -- seq )
  26     <file-reader> lines ;
  27
  28 : with-file-reader ( path encoding quot -- )
  29     [ <file-reader> ] dip with-input-stream ; inline
  30
  31 : file-contents ( path encoding -- str )
  32     <file-reader> contents ;
  33
  34 : with-file-writer ( path encoding quot -- )
  35     [ <file-writer> ] dip with-output-stream ; inline
  36
  37 : set-file-lines ( seq path encoding -- )
  38     [ [ print ] each ] with-file-writer ;
  39
  40 : set-file-contents ( str path encoding -- )
  41     [ write ] with-file-writer ;
  42
  43 : with-file-appender ( path encoding quot -- )
  44     [ <file-appender> ] dip with-output-stream ; inline
  45
  46 ! Pathnames
  47 : path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
  48
  49 : path-separator ( -- string ) os windows? "\\" "/" ? ;
  50
  51 : trim-right-separators ( str -- newstr )
  52     [ path-separator? ] trim-right ;
  53
  54 : trim-left-separators ( str -- newstr )
  55     [ path-separator? ] trim-left ;
  56
  57 : last-path-separator ( path -- n ? )
  58     [ length 1- ] keep [ path-separator? ] find-last-from ;
  59
  60 HOOK: root-directory? io-backend ( path -- ? )
  61
  62 M: object root-directory? ( path -- ? )
  63     [ f ] [ [ path-separator? ] all? ] if-empty ;
  64
  65 ERROR: no-parent-directory path ;
  66
  67 : parent-directory ( path -- parent )
  68     dup root-directory? [
  69         trim-right-separators
  70         dup last-path-separator [
  71             1+ cut
  72         ] [
  73             drop "." swap
  74         ] if
  75         { "" "." ".." } member? [
  76             no-parent-directory
  77         ] when
  78     ] unless ;
  79
  80 <PRIVATE
  81
  82 : head-path-separator? ( path1 ? -- ?' )
  83     [
  84         [ t ] [ first path-separator? ] if-empty
  85     ] [
  86         drop f
  87     ] if ;
  88
  89 : head.? ( path -- ? ) "." ?head head-path-separator? ;
  90
  91 : head..? ( path -- ? ) ".." ?head head-path-separator? ;
  92
  93 : append-path-empty ( path1 path2 -- path' )
  94     {
  95         { [ dup head.? ] [
  96             rest trim-left-separators append-path-empty
  97         ] }
  98         { [ dup head..? ] [ drop no-parent-directory ] }
  99         [ nip ]
 100     } cond ;
 101
 102 PRIVATE>
 103
 104 : windows-absolute-path? ( path -- path ? )
 105     {
 106         { [ dup "\\\\?\\" head? ] [ t ] }
 107         { [ dup length 2 < ] [ f ] }
 108         { [ dup second CHAR: : = ] [ t ] }
 109         [ f ]
 110     } cond ;
 111
 112 : absolute-path? ( path -- ? )
 113     {
 114         { [ dup empty? ] [ f ] }
 115         { [ dup "resource:" head? ] [ t ] }
 116         { [ os windows? ] [ windows-absolute-path? ] }
 117         { [ dup first path-separator? ] [ t ] }
 118         [ f ]
 119     } cond nip ;
 120
 121 : append-path ( str1 str2 -- str )
 122     {
 123         { [ over empty? ] [ append-path-empty ] }
 124         { [ dup empty? ] [ drop ] }
 125         { [ over trim-right-separators "." = ] [ nip ] }
 126         { [ dup absolute-path? ] [ nip ] }
 127         { [ dup head.? ] [ rest trim-left-separators append-path ] }
 128         { [ dup head..? ] [
 129             2 tail trim-left-separators
 130             [ parent-directory ] dip append-path
 131         ] }
 132         { [ over absolute-path? over first path-separator? and ] [
 133             [ 2 head ] dip append
 134         ] }
 135         [
 136             [ trim-right-separators "/" ] dip
 137             trim-left-separators 3append
 138         ]
 139     } cond ;
 140
 141 : prepend-path ( str1 str2 -- str )
 142     swap append-path ; inline
 143
 144 : file-name ( path -- string )
 145     dup root-directory? [
 146         trim-right-separators
 147         dup last-path-separator [ 1+ tail ] [
 148             drop "resource:" ?head [ file-name ] when
 149         ] if
 150     ] unless ;
 151
 152 : file-extension ( filename -- extension )
 153     "." split1-last nip ;
 154
 155 ! File info
 156 TUPLE: file-info type size permissions created modified
 157 accessed ;
 158
 159 HOOK: file-info io-backend ( path -- info )
 160
 161 ! Symlinks
 162 HOOK: link-info io-backend ( path -- info )
 163
 164 HOOK: make-link io-backend ( target symlink -- )
 165
 166 HOOK: read-link io-backend ( symlink -- path )
 167
 168 : copy-link ( target symlink -- )
 169     [ read-link ] dip make-link ;
 170
 171 SYMBOL: +regular-file+
 172 SYMBOL: +directory+
 173 SYMBOL: +symbolic-link+
 174 SYMBOL: +character-device+
 175 SYMBOL: +block-device+
 176 SYMBOL: +fifo+
 177 SYMBOL: +socket+
 178 SYMBOL: +whiteout+
 179 SYMBOL: +unknown+
 180
 181 ! File metadata
 182 : exists? ( path -- ? ) normalize-path (exists?) ;
 183
 184 : directory? ( file-info -- ? ) type>> +directory+ = ;
 185
 186 ! File-system
 187
 188 HOOK: file-systems os ( -- array )
 189
 190 TUPLE: file-system-info device-name mount-point type
 191 available-space free-space used-space total-space ;
 192
 193 HOOK: file-system-info os ( path -- file-system-info )
 194
 195 <PRIVATE
 196
 197 HOOK: cd io-backend ( path -- )
 198
 199 HOOK: cwd io-backend ( -- path )
 200
 201 M: object cwd ( -- path ) "." ;
 202
 203 PRIVATE>
 204
 205 SYMBOL: current-directory
 206
 207 [
 208     cwd current-directory set-global
 209     13 getenv cwd prepend-path \ image set-global
 210     14 getenv cwd prepend-path \ vm set-global
 211     image parent-directory "resource-path" set-global
 212 ] "io.files" add-init-hook
 213
 214 : resource-path ( path -- newpath )
 215     "resource-path" get prepend-path ;
 216
 217 : (normalize-path) ( path -- path' )
 218     "resource:" ?head [
 219         trim-left-separators resource-path
 220         (normalize-path)
 221     ] [
 222         current-directory get prepend-path
 223     ] if ;
 224
 225 M: object normalize-path ( path -- path' )
 226     (normalize-path) ;
 227
 228 : set-current-directory ( path -- )
 229     (normalize-path) current-directory set ;
 230
 231 : with-directory ( path quot -- )
 232     [ (normalize-path) current-directory ] dip with-variable ; inline
 233
 234 ! Creating directories
 235 HOOK: make-directory io-backend ( path -- )
 236
 237 : make-directories ( path -- )
 238     normalize-path trim-right-separators {
 239         { [ dup "." = ] [ ] }
 240         { [ dup root-directory? ] [ ] }
 241         { [ dup empty? ] [ ] }
 242         { [ dup exists? ] [ ] }
 243         [
 244             dup parent-directory make-directories
 245             dup make-directory
 246         ]
 247     } cond drop ;
 248
 249 TUPLE: directory-entry name type ;
 250
 251 HOOK: >directory-entry os ( byte-array -- directory-entry )
 252
 253 HOOK: (directory-entries) os ( path -- seq )
 254
 255 : directory-entries ( path -- seq )
 256     normalize-path
 257     (directory-entries)
 258     [ name>> { "." ".." } member? not ] filter ;
 259
 260 : directory-files ( path -- seq )
 261     directory-entries [ name>> ] map ;
 262
 263 : with-directory-files ( path quot -- )
 264     [ "" directory-files ] prepose with-directory ; inline
 265
 266 ! Touching files
 267 HOOK: touch-file io-backend ( path -- )
 268
 269 ! Deleting files
 270 HOOK: delete-file io-backend ( path -- )
 271
 272 HOOK: delete-directory io-backend ( path -- )
 273
 274 : delete-tree ( path -- )
 275     dup link-info type>> +directory+ = [
 276         [ [ [ delete-tree ] each ] with-directory-files ]
 277         [ delete-directory ]
 278         bi
 279     ] [ delete-file ] if ;
 280
 281 : to-directory ( from to -- from to' )
 282     over file-name append-path ;
 283
 284 ! Moving and renaming files
 285 HOOK: move-file io-backend ( from to -- )
 286
 287 : move-file-into ( from to -- )
 288     to-directory move-file ;
 289
 290 : move-files-into ( files to -- )
 291     [ move-file-into ] curry each ;
 292
 293 ! Copying files
 294 HOOK: copy-file io-backend ( from to -- )
 295
 296 M: object copy-file
 297     dup parent-directory make-directories
 298     binary <file-writer> [
 299         swap binary <file-reader> [
 300             swap stream-copy
 301         ] with-disposal
 302     ] with-disposal ;
 303
 304 : copy-file-into ( from to -- )
 305     to-directory copy-file ;
 306
 307 : copy-files-into ( files to -- )
 308     [ copy-file-into ] curry each ;
 309
 310 DEFER: copy-tree-into
 311
 312 : copy-tree ( from to -- )
 313     normalize-path
 314     over link-info type>>
 315     {
 316         { +symbolic-link+ [ copy-link ] }
 317         { +directory+ [
 318             swap [
 319                 [ swap copy-tree-into ] with each
 320             ] with-directory-files
 321         ] }
 322         [ drop copy-file ]
 323     } case ;
 324
 325 : copy-tree-into ( from to -- )
 326     to-directory copy-tree ;
 327
 328 : copy-trees-into ( files to -- )
 329     [ copy-tree-into ] curry each ;
 330
 331 ! Special paths
 332
 333 : temp-directory ( -- path )
 334     "temp" resource-path dup make-directories ;
 335
 336 : temp-file ( name -- path )
 337     temp-directory prepend-path ;
 338
 339 ! Pathname presentations
 340 TUPLE: pathname string ;
 341
 342 C: <pathname> pathname
 343
 344 M: pathname <=> [ string>> ] compare ;
 345
 346 ! Home directory
 347 HOOK: home io-backend ( -- dir )
 348
 349 M: object home "" resource-path ;