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