basis/io/directories/directories.factor

   1 ! Copyright (C) 2004, 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors combinators combinators.short-circuit
   4 continuations destructors fry io io.backend io.encodings.binary
   5 io.files io.pathnames kernel namespaces sequences system vocabs ;
   6 IN: io.directories
   7
   8 : set-current-directory ( path -- )
   9     absolute-path current-directory set ;
  10
  11 : with-directory ( path quot -- )
  12     [ absolute-path current-directory ] dip with-variable ; inline
  13
  14 : with-resource-directory ( quot -- )
  15     [ "resource:" ] dip with-directory ; inline
  16
  17 ! Creating directories
  18 HOOK: make-directory io-backend ( path -- )
  19
  20 DEFER: make-parent-directories
  21
  22 : make-directories ( path -- )
  23     normalize-path trim-tail-separators dup {
  24         [ "." = ]
  25         [ root-directory? ]
  26         [ empty? ]
  27         [ exists? ]
  28     } 1|| [
  29         make-parent-directories
  30         dup make-directory
  31     ] unless drop ;
  32
  33 : make-parent-directories ( filename -- filename )
  34     dup parent-directory make-directories ;
  35
  36 ! Listing directories
  37 TUPLE: directory-entry name type ;
  38
  39 C: <directory-entry> directory-entry
  40
  41 HOOK: (directory-entries) os ( path -- seq )
  42
  43 : directory-entries ( path -- seq )
  44     normalize-path
  45     (directory-entries)
  46     [ name>> { "." ".." } member? ] reject ;
  47
  48 : directory-files ( path -- seq )
  49     directory-entries [ name>> ] map! ;
  50
  51 : with-directory-entries ( path quot -- )
  52     '[ "" directory-entries @ ] with-directory ; inline
  53
  54 : with-directory-files ( path quot -- )
  55     '[ "" directory-files @ ] with-directory ; inline
  56
  57 : qualified-directory-entries ( path -- seq )
  58     absolute-path
  59     dup directory-entries [ [ append-path ] change-name ] with map! ;
  60
  61 : qualified-directory-files ( path -- seq )
  62     absolute-path
  63     dup directory-files [ append-path ] with map! ;
  64
  65 : with-qualified-directory-files ( path quot -- )
  66     '[ "" qualified-directory-files @ ] with-directory ; inline
  67
  68 : with-qualified-directory-entries ( path quot -- )
  69     '[ "" qualified-directory-entries @ ] with-directory ; inline
  70
  71 ! Touching files
  72 HOOK: touch-file io-backend ( path -- )
  73
  74 ! Deleting files
  75 HOOK: delete-file io-backend ( path -- )
  76
  77 HOOK: delete-directory io-backend ( path -- )
  78
  79 : ?delete-file ( path -- )
  80     '[ _ delete-file ] ignore-errors ;
  81
  82 : to-directory ( from to -- from to' )
  83     over file-name append-path ;
  84
  85 ! Moving and renaming files
  86 HOOK: move-file io-backend ( from to -- )
  87 HOOK: move-file-atomically io-backend ( from to -- )
  88
  89 : move-file-into ( from to -- )
  90     to-directory move-file ;
  91
  92 : move-files-into ( files to -- )
  93     '[ _ move-file-into ] each ;
  94
  95 ! Copying files
  96 HOOK: copy-file io-backend ( from to -- )
  97
  98 M: object copy-file
  99     make-parent-directories binary <file-writer> [
 100         swap binary <file-reader> [
 101             swap stream-copy
 102         ] with-disposal
 103     ] with-disposal ;
 104
 105 : copy-file-into ( from to -- )
 106     to-directory copy-file ;
 107
 108 : copy-files-into ( files to -- )
 109     '[ _ copy-file-into ] each ;
 110
 111 {
 112     { [ os unix? ] [ "io.directories.unix" require ] }
 113     { [ os windows? ] [ "io.directories.windows" require ] }
 114 } cond