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