basis/io/files/windows/windows.factor

   1 ! Copyright (C) 2008 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien.c-types io.binary io.backend io.files
   4 io.files.types io.buffers io.encodings.utf16n io.ports
   5 io.backend.windows kernel math splitting fry alien.strings
   6 windows windows.kernel32 windows.time calendar combinators
   7 math.functions sequences namespaces make words symbols system
   8 destructors accessors math.bitwise continuations windows.errors
   9 arrays byte-arrays generalizations ;
  10 IN: io.files.windows
  11
  12 : open-file ( path access-mode create-mode flags -- handle )
  13     [
  14         [ share-mode default-security-attributes ] 2dip
  15         CreateFile-flags f CreateFile opened-file
  16     ] with-destructors ;
  17
  18 : open-pipe-r/w ( path -- win32-file )
  19     { GENERIC_READ GENERIC_WRITE } flags
  20     OPEN_EXISTING 0 open-file ;
  21
  22 : open-read ( path -- win32-file )
  23     GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
  24
  25 : open-write ( path -- win32-file )
  26     GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
  27
  28 : (open-append) ( path -- win32-file )
  29     GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
  30
  31 : open-existing ( path -- win32-file )
  32     { GENERIC_READ GENERIC_WRITE } flags
  33     share-mode
  34     f
  35     OPEN_EXISTING
  36     FILE_FLAG_BACKUP_SEMANTICS
  37     f CreateFileW dup win32-error=0/f <win32-file> ;
  38
  39 : maybe-create-file ( path -- win32-file ? )
  40     #! return true if file was just created
  41     { GENERIC_READ GENERIC_WRITE } flags
  42     share-mode
  43     f
  44     OPEN_ALWAYS
  45     0 CreateFile-flags
  46     f CreateFileW dup win32-error=0/f <win32-file>
  47     GetLastError ERROR_ALREADY_EXISTS = not ;
  48
  49 : set-file-pointer ( handle length method -- )
  50     [ dupd d>w/w <uint> ] dip SetFilePointer
  51     INVALID_SET_FILE_POINTER = [
  52         CloseHandle "SetFilePointer failed" throw
  53     ] when drop ;
  54
  55 HOOK: open-append os ( path -- win32-file )
  56
  57 TUPLE: FileArgs
  58     hFile lpBuffer nNumberOfBytesToRead
  59     lpNumberOfBytesRet lpOverlapped ;
  60
  61 C: <FileArgs> FileArgs
  62
  63 : make-FileArgs ( port -- <FileArgs> )
  64     {
  65         [ handle>> check-disposed ]
  66         [ handle>> handle>> ]
  67         [ buffer>> ]
  68         [ buffer>> buffer-length ]
  69         [ drop "DWORD" <c-object> ]
  70         [ FileArgs-overlapped ]
  71     } cleave <FileArgs> ;
  72
  73 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
  74     {
  75         [ hFile>> ]
  76         [ lpBuffer>> buffer-end ]
  77         [ lpBuffer>> buffer-capacity ]
  78         [ lpNumberOfBytesRet>> ]
  79         [ lpOverlapped>> ]
  80     } cleave ;
  81
  82 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
  83     {
  84         [ hFile>> ]
  85         [ lpBuffer>> buffer@ ]
  86         [ lpBuffer>> buffer-length ]
  87         [ lpNumberOfBytesRet>> ]
  88         [ lpOverlapped>> ]
  89     } cleave ;
  90
  91 M: windows (file-reader) ( path -- stream )
  92     open-read <input-port> ;
  93
  94 M: windows (file-writer) ( path -- stream )
  95     open-write <output-port> ;
  96
  97 M: windows (file-appender) ( path -- stream )
  98     open-append <output-port> ;
  99
 100 SYMBOLS: +read-only+ +hidden+ +system+
 101 +archive+ +device+ +normal+ +temporary+
 102 +sparse-file+ +reparse-point+ +compressed+ +offline+
 103 +not-content-indexed+ +encrypted+ ;
 104
 105 : win32-file-attribute ( n attr symbol -- )
 106     rot mask? [ , ] [ drop ] if ;
 107
 108 : win32-file-attributes ( n -- seq )
 109     [
 110         {
 111             [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
 112             [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
 113             [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
 114             [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
 115             [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
 116             [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
 117             [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
 118             [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
 119             [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
 120             [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
 121             [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
 122             [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
 123             [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
 124             [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
 125         } cleave
 126     ] { } make ;
 127
 128 : win32-file-type ( n -- symbol )
 129     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 130
 131 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
 132     [ timestamp>FILETIME ] tri@
 133     SetFileTime win32-error=0/f ;