extra/io/windows/nt/files/files.factor

   1 USING: continuations destructors io.buffers io.files io.backend
   2 io.timeouts io.ports io.windows io.windows.files
   3 io.windows.nt.backend windows windows.kernel32
   4 kernel libc math threads system
   5 alien.c-types alien.arrays alien.strings sequences combinators
   6 combinators.short-circuit ascii splitting alien strings
   7 assocs namespaces io.files.private accessors tr ;
   8 IN: io.windows.nt.files
   9
  10 M: winnt cwd
  11     MAX_UNICODE_PATH dup "ushort" <c-array>
  12     [ GetCurrentDirectory win32-error=0/f ] keep
  13     utf16n alien>string ;
  14
  15 M: winnt cd
  16     SetCurrentDirectory win32-error=0/f ;
  17
  18 : unicode-prefix ( -- seq )
  19     "\\\\?\\" ; inline
  20
  21 M: winnt root-directory? ( path -- ? )
  22     {
  23         { [ dup empty? ] [ f ] }
  24         { [ dup [ path-separator? ] all? ] [ t ] }
  25         { [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
  26         [ f ]
  27     } cond nip ;
  28
  29 ERROR: not-absolute-path ;
  30
  31 : root-directory ( string -- string' )
  32     dup {
  33         [ length 2 >= ]
  34         [ second CHAR: : = ]
  35         [ first Letter? ]
  36     } 1&& [ 2 head ] [ not-absolute-path ] if ;
  37
  38 : prepend-prefix ( string -- string' )
  39     dup unicode-prefix head? [
  40         unicode-prefix prepend
  41     ] unless ;
  42
  43 TR: normalize-separators "/" "\\" ;
  44
  45 M: winnt normalize-path ( string -- string' )
  46     (normalize-path)
  47     normalize-separators
  48     prepend-prefix ;
  49
  50 M: winnt CreateFile-flags ( DWORD -- DWORD )
  51     FILE_FLAG_OVERLAPPED bitor ;
  52
  53 M: winnt FileArgs-overlapped ( port -- overlapped )
  54     make-overlapped ;
  55
  56 M: winnt open-append
  57     [ dup file-info size>> ] [ drop 0 ] recover
  58     >r (open-append) r> >>ptr ;