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 : make-directories ( path -- )
  21     normalize-path trim-tail-separators dup {
  22         [ "." = ]
  23         [ root-directory? ]
  24         [ empty? ]
  25         [ exists? ]
  26     } 1|| [
  27         dup parent-directory make-directories
  28         dup make-directory
  29     ] unless drop ;
  30
  31 ! Listing directories
  32 TUPLE: directory-entry name type ;
  33
  34 C: <directory-entry> directory-entry
  35
  36 HOOK: (directory-entries) os ( path -- seq )
  37
  38 : directory-entries ( path -- seq )
  39     normalize-path
  40     (directory-entries)
  41     [ name>> { "." ".." } member? ] reject ;
  42
  43 : directory-files ( path -- seq )
  44     directory-entries [ name>> ] map! ;
  45
  46 : with-directory-entries ( path quot -- )
  47     '[ "" directory-entries @ ] with-directory ; inline
  48
  49 : with-directory-files ( path quot -- )
  50     '[ "" directory-files @ ] with-directory ; inline
  51
  52 ! Touching files
  53 HOOK: touch-file io-backend ( path -- )
  54
  55 ! Deleting files
  56 HOOK: delete-file io-backend ( path -- )
  57
  58 HOOK: delete-directory io-backend ( path -- )
  59
  60 : ?delete-file ( path -- )
  61     '[ _ delete-file ] ignore-errors ;
  62
  63 : to-directory ( from to -- from to' )
  64     over file-name append-path ;
  65
  66 ! Moving and renaming files
  67 HOOK: move-file io-backend ( from to -- )
  68
  69 : move-file-into ( from to -- )
  70     to-directory move-file ;
  71
  72 : move-files-into ( files to -- )
  73     '[ _ move-file-into ] each ;
  74
  75 ! Copying files
  76 HOOK: copy-file io-backend ( from to -- )
  77
  78 M: object copy-file
  79     dup parent-directory make-directories
  80     binary <file-writer> [
  81         swap binary <file-reader> [
  82             swap stream-copy
  83         ] with-disposal
  84     ] with-disposal ;
  85
  86 : copy-file-into ( from to -- )
  87     to-directory copy-file ;
  88
  89 : copy-files-into ( files to -- )
  90     '[ _ copy-file-into ] each ;
  91
  92 {
  93     { [ os unix? ] [ "io.directories.unix" require ] }
  94     { [ os windows? ] [ "io.directories.windows" require ] }
  95 } cond