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 alien.c-types alien.data alien.strings
   4 alien.syntax arrays assocs classes.struct combinators
   5 combinators.short-circuit continuations destructors environment
   6 io io.backend io.binary io.buffers io.encodings.utf16n io.files
   7 io.files.private io.files.types io.pathnames io.ports
   8 io.streams.c io.streams.null io.timeouts kernel libc literals
   9 locals make math math.bitwise namespaces sequences
  10 specialized-arrays system threads tr windows windows.errors
  11 windows.handles windows.kernel32 windows.shell32 windows.time
  12 windows.types ;
  13 SPECIALIZED-ARRAY: ushort
  14 IN: io.files.windows
  15
  16 HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
  17 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
  18 HOOK: add-completion io-backend ( port -- port )
  19 HOOK: open-append os ( path -- win32-file )
  20
  21 TUPLE: win32-file < win32-handle ptr ;
  22
  23 : <win32-file> ( handle -- win32-file )
  24     win32-file new-win32-handle ;
  25
  26 M: win32-file dispose
  27     [ cancel-operation ] [ call-next-method ] bi ;
  28
  29 : opened-file ( handle -- win32-file )
  30     check-invalid-handle <win32-file> |dispose add-completion ;
  31
  32 CONSTANT: share-mode
  33     flags{
  34         FILE_SHARE_READ
  35         FILE_SHARE_WRITE
  36         FILE_SHARE_DELETE
  37     }
  38
  39 : default-security-attributes ( -- obj )
  40     SECURITY_ATTRIBUTES <struct>
  41     SECURITY_ATTRIBUTES heap-size >>nLength ;
  42
  43 TUPLE: FileArgs
  44     hFile lpBuffer nNumberOfBytesToRead
  45     lpNumberOfBytesRet lpOverlapped ;
  46
  47 C: <FileArgs> FileArgs
  48
  49 : make-FileArgs ( port -- <FileArgs> )
  50     {
  51         [ handle>> check-disposed ]
  52         [ handle>> handle>> ]
  53         [ buffer>> ]
  54         [ buffer>> buffer-length ]
  55         [ drop 0 DWORD <ref> ]
  56         [ FileArgs-overlapped ]
  57     } cleave <FileArgs> ;
  58
  59 ! Global variable with assoc mapping overlapped to threads
  60 SYMBOL: pending-overlapped
  61
  62 TUPLE: io-callback port thread ;
  63
  64 C: <io-callback> io-callback
  65
  66 : (make-overlapped) ( -- overlapped-ext )
  67     OVERLAPPED malloc-struct &free ;
  68
  69 : make-overlapped ( port -- overlapped-ext )
  70     [ (make-overlapped) ] dip
  71     handle>> ptr>> [ >>offset ] when* ;
  72
  73 M: windows FileArgs-overlapped ( port -- overlapped )
  74     make-overlapped ;
  75
  76 : <completion-port> ( handle existing -- handle )
  77      f 1 CreateIoCompletionPort dup win32-error=0/f ;
  78
  79 SYMBOL: master-completion-port
  80
  81 : <master-completion-port> ( -- handle )
  82     INVALID_HANDLE_VALUE f <completion-port> ;
  83
  84 M: windows add-completion ( win32-handle -- win32-handle )
  85     dup handle>> master-completion-port get-global <completion-port> drop ;
  86
  87 : eof? ( error -- ? )
  88     { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
  89
  90 : twiddle-thumbs ( overlapped port -- bytes-transferred )
  91     [
  92         drop
  93         [ self ] dip >c-ptr pending-overlapped get-global set-at
  94         "I/O" suspend {
  95             { [ dup integer? ] [ ] }
  96             { [ dup array? ] [
  97                 first dup eof?
  98                 [ drop 0 ] [ n>win32-error-string throw ] if
  99             ] }
 100         } cond
 101     ] with-timeout ;
 102
 103 :: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
 104     nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
 105     master-completion-port get-global
 106     { int void* pointer: OVERLAPPED }
 107     [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
 108     :> ( error? bytes key overlapped )
 109     bytes overlapped error? ;
 110
 111 : resume-callback ( result overlapped -- )
 112     >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
 113
 114 : handle-overlapped ( nanos -- ? )
 115     wait-for-overlapped [
 116         [
 117             [ drop GetLastError 1array ] dip resume-callback t
 118         ] [ drop f ] if*
 119     ] [ resume-callback t ] if ;
 120
 121 M: win32-handle cancel-operation
 122     [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
 123
 124 M: windows io-multiplex ( nanos -- )
 125     handle-overlapped [ 0 io-multiplex ] when ;
 126
 127 M: windows init-io ( -- )
 128     <master-completion-port> master-completion-port set-global
 129     H{ } clone pending-overlapped set-global ;
 130
 131 ERROR: invalid-file-size n ;
 132
 133 : handle>file-size ( handle -- n )
 134     0 ulonglong <ref> [ GetFileSizeEx win32-error=0/f ] keep ulonglong deref ;
 135
 136 ERROR: seek-before-start n ;
 137
 138 : set-seek-ptr ( n handle -- )
 139     [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
 140
 141 M: windows tell-handle ( handle -- n ) ptr>> ;
 142
 143 M: windows seek-handle ( n seek-type handle -- )
 144     swap {
 145         { seek-absolute [ set-seek-ptr ] }
 146         { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
 147         { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
 148         [ bad-seek-type ]
 149     } case ;
 150
 151 : file-error? ( n -- eof? )
 152     zero? [
 153         GetLastError {
 154             { [ dup expected-io-error? ] [ drop f ] }
 155             { [ dup eof? ] [ drop t ] }
 156             [ n>win32-error-string throw ]
 157         } cond
 158     ] [ f ] if ;
 159
 160 : wait-for-file ( FileArgs n port -- n )
 161     swap file-error?
 162     [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
 163
 164 : update-file-ptr ( n port -- )
 165     handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
 166
 167 : finish-write ( n port -- )
 168     [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
 169
 170 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
 171     {
 172         [ hFile>> ]
 173         [ lpBuffer>> buffer-end ]
 174         [ lpBuffer>> buffer-capacity ]
 175         [ lpNumberOfBytesRet>> ]
 176         [ lpOverlapped>> ]
 177     } cleave ;
 178
 179 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
 180     {
 181         [ hFile>> ]
 182         [ lpBuffer>> buffer@ ]
 183         [ lpBuffer>> buffer-length ]
 184         [ lpNumberOfBytesRet>> ]
 185         [ lpOverlapped>> ]
 186     } cleave ;
 187
 188 M: windows (wait-to-write)
 189     [
 190         [ make-FileArgs dup setup-write WriteFile ]
 191         [ wait-for-file ]
 192         [ finish-write ]
 193         tri
 194     ] with-destructors ;
 195
 196 : finish-read ( n port -- )
 197     [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
 198
 199 M: windows (wait-to-read) ( port -- )
 200     [
 201         [ make-FileArgs dup setup-read ReadFile ]
 202         [ wait-for-file ]
 203         [ finish-read ]
 204         tri
 205     ] with-destructors ;
 206
 207 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
 208
 209 M: windows init-stdio
 210     console-app?
 211     [ init-c-stdio ]
 212     [ null-reader null-writer null-writer set-stdio ] if ;
 213
 214 : open-file ( path access-mode create-mode flags -- handle )
 215     [
 216         [ share-mode default-security-attributes ] 2dip
 217         CreateFile-flags f CreateFile opened-file
 218     ] with-destructors ;
 219
 220 : open-r/w ( path -- win32-file )
 221     flags{ GENERIC_READ GENERIC_WRITE }
 222     OPEN_EXISTING 0 open-file ;
 223
 224 : open-read ( path -- win32-file )
 225     GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
 226
 227 : open-write ( path -- win32-file )
 228     GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
 229
 230 : (open-append) ( path -- win32-file )
 231     GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
 232
 233 : open-existing ( path -- win32-file )
 234     flags{ GENERIC_READ GENERIC_WRITE }
 235     share-mode
 236     f
 237     OPEN_EXISTING
 238     FILE_FLAG_BACKUP_SEMANTICS
 239     f CreateFileW dup win32-error=0/f <win32-file> ;
 240
 241 : maybe-create-file ( path -- win32-file ? )
 242     #! return true if file was just created
 243     flags{ GENERIC_READ GENERIC_WRITE }
 244     share-mode
 245     f
 246     OPEN_ALWAYS
 247     0 CreateFile-flags
 248     f CreateFileW dup win32-error=0/f <win32-file>
 249     GetLastError ERROR_ALREADY_EXISTS = not ;
 250
 251 : set-file-pointer ( handle length method -- )
 252     [ [ handle>> ] dip d>w/w uint <ref> ] dip SetFilePointer
 253     INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
 254
 255 M: windows (file-reader) ( path -- stream )
 256     open-read <input-port> ;
 257
 258 M: windows (file-writer) ( path -- stream )
 259     open-write <output-port> ;
 260
 261 M: windows (file-appender) ( path -- stream )
 262     open-append <output-port> ;
 263
 264 SYMBOLS: +read-only+ +hidden+ +system+
 265 +archive+ +device+ +normal+ +temporary+
 266 +sparse-file+ +reparse-point+ +compressed+ +offline+
 267 +not-content-indexed+ +encrypted+ ;
 268
 269 : win32-file-attribute ( n symbol attr -- )
 270     rot mask? [ , ] [ drop ] if ;
 271
 272 : win32-file-attributes ( n -- seq )
 273     [
 274         {
 275             [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
 276             [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
 277             [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
 278             [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
 279             [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
 280             [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
 281             [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
 282             [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
 283             [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
 284             [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
 285             [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
 286             [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
 287             [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
 288             [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
 289         } cleave
 290     ] { } make ;
 291
 292 : win32-file-type ( n -- symbol )
 293     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 294
 295 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
 296     [ timestamp>FILETIME ] tri@
 297     SetFileTime win32-error=0/f ;
 298
 299 M: windows cwd
 300     MAX_UNICODE_PATH dup <ushort-array>
 301     [ GetCurrentDirectory win32-error=0/f ] keep
 302     utf16n alien>string ;
 303
 304 M: windows cd
 305     SetCurrentDirectory win32-error=0/f ;
 306
 307 CONSTANT: unicode-prefix "\\\\?\\"
 308
 309 M: windows root-directory? ( path -- ? )
 310     {
 311         { [ dup empty? ] [ drop f ] }
 312         { [ dup [ path-separator? ] all? ] [ drop t ] }
 313         { [ dup trim-tail-separators { [ length 2 = ]
 314           [ second CHAR: : = ] } 1&& ] [ drop t ] }
 315         { [ dup unicode-prefix head? ]
 316           [ trim-tail-separators length unicode-prefix length 2 + = ] }
 317         [ drop f ]
 318     } cond ;
 319
 320 : prepend-prefix ( string -- string' )
 321     dup unicode-prefix head? [
 322         unicode-prefix prepend
 323     ] unless ;
 324
 325 TR: normalize-separators "/" "\\" ;
 326
 327 <PRIVATE
 328
 329 : unc-path? ( string -- ? )
 330     [ "//" head? ] [ "\\\\" head? ] bi or ;
 331
 332 PRIVATE>
 333
 334 M: windows normalize-path ( string -- string' )
 335     dup unc-path? [
 336         normalize-separators
 337     ] [
 338         absolute-path
 339         normalize-separators
 340         prepend-prefix
 341     ] if ;
 342
 343 M: windows CreateFile-flags ( DWORD -- DWORD )
 344     FILE_FLAG_OVERLAPPED bitor ;
 345
 346 <PRIVATE
 347
 348 : windows-file-size ( path -- size )
 349     normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
 350     [ GetFileAttributesEx win32-error=0/f ] keep
 351     [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
 352
 353 PRIVATE>
 354
 355 M: windows open-append
 356     [ dup windows-file-size ] [ drop 0 ] recover
 357     [ (open-append) ] dip >>ptr ;
 358
 359 M: windows home
 360     {
 361         [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
 362         [ "USERPROFILE" os-env ]
 363         [ my-documents ]
 364     } 0|| ;