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     >r <file-reader> r> with-input-stream ; inline
  30
  31 : file-contents ( path encoding -- str )
  32     <file-reader> contents ;
  33
  34 : with-file-writer ( path encoding quot -- )
  35     >r <file-writer> r> 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     >r <file-appender> r> 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             >r parent-directory r> append-path
 131         ] }
 132         { [ over absolute-path? over first path-separator? and ] [
 133             >r 2 head r> append
 134         ] }
 135         [
 136             >r trim-right-separators "/" r>
 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     "." last-split1 nip ;
 154
 155 ! File info
 156 TUPLE: file-info type size permissions modified ;
 157
 158 HOOK: file-info io-backend ( path -- info )
 159
 160 ! Symlinks
 161 HOOK: link-info io-backend ( path -- info )
 162
 163 HOOK: make-link io-backend ( target symlink -- )
 164
 165 HOOK: read-link io-backend ( symlink -- path )
 166
 167 : copy-link ( target symlink -- )
 168     >r read-link r> make-link ;
 169
 170 SYMBOL: +regular-file+
 171 SYMBOL: +directory+
 172 SYMBOL: +symbolic-link+
 173 SYMBOL: +character-device+
 174 SYMBOL: +block-device+
 175 SYMBOL: +fifo+
 176 SYMBOL: +socket+
 177 SYMBOL: +unknown+
 178
 179 ! File metadata
 180 : exists? ( path -- ? ) normalize-path (exists?) ;
 181
 182 : directory? ( file-info -- ? ) type>> +directory+ = ;
 183
 184 <PRIVATE
 185
 186 HOOK: cd io-backend ( path -- )
 187
 188 HOOK: cwd io-backend ( -- path )
 189
 190 M: object cwd ( -- path ) "." ;
 191
 192 PRIVATE>
 193
 194 SYMBOL: current-directory
 195
 196 [
 197     cwd current-directory set-global
 198     13 getenv cwd prepend-path \ image set-global
 199     14 getenv cwd prepend-path \ vm set-global
 200     image parent-directory "resource-path" set-global
 201 ] "io.files" add-init-hook
 202
 203 : resource-path ( path -- newpath )
 204     "resource-path" get prepend-path ;
 205
 206 : (normalize-path) ( path -- path' )
 207     "resource:" ?head [
 208         trim-left-separators resource-path
 209         (normalize-path)
 210     ] [
 211         current-directory get prepend-path
 212     ] if ;
 213
 214 M: object normalize-path ( path -- path' )
 215     (normalize-path) ;
 216
 217 : set-current-directory ( path -- )
 218     (normalize-path) current-directory set ;
 219
 220 : with-directory ( path quot -- )
 221     >r (normalize-path) current-directory r> with-variable ; inline
 222
 223 ! Creating directories
 224 HOOK: make-directory io-backend ( path -- )
 225
 226 : make-directories ( path -- )
 227     normalize-path trim-right-separators {
 228         { [ dup "." = ] [ ] }
 229         { [ dup root-directory? ] [ ] }
 230         { [ dup empty? ] [ ] }
 231         { [ dup exists? ] [ ] }
 232         [
 233             dup parent-directory make-directories
 234             dup make-directory
 235         ]
 236     } cond drop ;
 237
 238 ! Directory listings
 239 : fixup-directory ( path seq -- newseq )
 240     [
 241         dup string?
 242         [ tuck append-path file-info directory? 2array ] [ nip ] if
 243     ] with map
 244     [ first { "." ".." } member? not ] filter ;
 245
 246 : directory ( path -- seq )
 247     normalize-directory dup (directory) fixup-directory ;
 248
 249 : directory* ( path -- seq )
 250     dup directory [ first2 >r append-path r> 2array ] with map ;
 251
 252 ! Touching files
 253 HOOK: touch-file io-backend ( path -- )
 254
 255 ! Deleting files
 256 HOOK: delete-file io-backend ( path -- )
 257
 258 HOOK: delete-directory io-backend ( path -- )
 259
 260 : delete-tree ( path -- )
 261     dup link-info type>> +directory+ = [
 262         dup directory over [
 263             [ first delete-tree ] each
 264         ] with-directory delete-directory
 265     ] [
 266         delete-file
 267     ] if ;
 268
 269 : to-directory ( from to -- from to' )
 270     over file-name append-path ;
 271
 272 ! Moving and renaming files
 273 HOOK: move-file io-backend ( from to -- )
 274
 275 : move-file-into ( from to -- )
 276     to-directory move-file ;
 277
 278 : move-files-into ( files to -- )
 279     [ move-file-into ] curry each ;
 280
 281 ! Copying files
 282 HOOK: copy-file io-backend ( from to -- )
 283
 284 M: object copy-file
 285     dup parent-directory make-directories
 286     binary <file-writer> [
 287         swap binary <file-reader> [
 288             swap stream-copy
 289         ] with-disposal
 290     ] with-disposal ;
 291
 292 : copy-file-into ( from to -- )
 293     to-directory copy-file ;
 294
 295 : copy-files-into ( files to -- )
 296     [ copy-file-into ] curry each ;
 297
 298 DEFER: copy-tree-into
 299
 300 : copy-tree ( from to -- )
 301     normalize-path
 302     over link-info type>>
 303     {
 304         { +symbolic-link+ [ copy-link ] }
 305         { +directory+ [
 306             >r dup directory r> rot [
 307                 [ >r first r> copy-tree-into ] curry each
 308             ] with-directory
 309         ] }
 310         [ drop copy-file ]
 311     } case ;
 312
 313 : copy-tree-into ( from to -- )
 314     to-directory copy-tree ;
 315
 316 : copy-trees-into ( files to -- )
 317     [ copy-tree-into ] curry each ;
 318
 319 ! Special paths
 320
 321 : temp-directory ( -- path )
 322     "temp" resource-path dup make-directories ;
 323
 324 : temp-file ( name -- path )
 325     temp-directory prepend-path ;
 326
 327 ! Pathname presentations
 328 TUPLE: pathname string ;
 329
 330 C: <pathname> pathname
 331
 332 M: pathname <=> [ string>> ] compare ;
 333
 334 ! Home directory
 335 HOOK: home os ( -- dir )
 336
 337 M: winnt home "USERPROFILE" os-env ;
 338
 339 M: wince home "" resource-path ;
 340
 341 M: unix home "HOME" os-env ;