basis/io/files/windows/windows.factor

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