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 arrays combinators combinators.short-circuit
   4 destructors fry io io.backend io.encodings.binary io.files
   5 io.files.types io.pathnames kernel namespaces sequences
   6 system vocabs vocabs.loader ;
   7 IN: io.directories
   8
   9 : set-current-directory ( path -- )
  10     absolute-path current-directory set ;
  11
  12 : with-directory ( path quot -- )
  13     [ absolute-path current-directory ] dip with-variable ; inline
  14
  15 ! Creating directories
  16 HOOK: make-directory io-backend ( path -- )
  17
  18 : make-directories ( path -- )
  19     normalize-path trim-tail-separators dup {
  20         [ "." = ]
  21         [ root-directory? ]
  22         [ empty? ]
  23         [ exists? ]
  24     } 1|| [
  25         dup parent-directory make-directories
  26         dup make-directory
  27     ] unless drop ;
  28
  29 ! Listing directories
  30 TUPLE: directory-entry name type ;
  31
  32 HOOK: >directory-entry os ( byte-array -- directory-entry )
  33
  34 HOOK: (directory-entries) os ( path -- seq )
  35
  36 : directory-entries ( path -- seq )
  37     normalize-path
  38     (directory-entries)
  39     [ name>> { "." ".." } member? not ] filter ;
  40
  41 : directory-files ( path -- seq )
  42     directory-entries [ name>> ] map! ;
  43
  44 : with-directory-entries ( path quot -- )
  45     '[ "" directory-entries @ ] with-directory ; inline
  46
  47 : with-directory-files ( path quot -- )
  48     '[ "" directory-files @ ] with-directory ; inline
  49
  50 ! Touching files
  51 HOOK: touch-file io-backend ( path -- )
  52
  53 ! Deleting files
  54 HOOK: delete-file io-backend ( path -- )
  55
  56 HOOK: delete-directory io-backend ( path -- )
  57
  58 : to-directory ( from to -- from to' )
  59     over file-name append-path ;
  60
  61 ! Moving and renaming files
  62 HOOK: move-file io-backend ( from to -- )
  63
  64 : move-file-into ( from to -- )
  65     to-directory move-file ;
  66
  67 : move-files-into ( files to -- )
  68     to-directory '[ _ move-file ] each ;
  69
  70 ! Copying files
  71 HOOK: copy-file io-backend ( from to -- )
  72
  73 M: object copy-file
  74     dup parent-directory make-directories
  75     binary <file-writer> [
  76         swap binary <file-reader> [
  77             swap stream-copy
  78         ] with-disposal
  79     ] with-disposal ;
  80
  81 : copy-file-into ( from to -- )
  82     to-directory copy-file ;
  83
  84 : copy-files-into ( files to -- )
  85     to-directory '[ _ copy-file ] each ;
  86
  87 {
  88     { [ os unix? ] [ "io.directories.unix" require ] }
  89     { [ os windows? ] [ "io.directories.windows" require ] }
  90 } cond