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 fry ;
  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>> [
  72         [ 32 bits >>offset ]
  73         [ -32 shift >>offset-high ] bi
  74     ] when* ;
  75
  76 M: windows FileArgs-overlapped ( port -- overlapped )
  77     make-overlapped ;
  78
  79 : <completion-port> ( handle existing -- handle )
  80      f 1 CreateIoCompletionPort dup win32-error=0/f ;
  81
  82 SYMBOL: master-completion-port
  83
  84 : <master-completion-port> ( -- handle )
  85     INVALID_HANDLE_VALUE f <completion-port> ;
  86
  87 M: windows add-completion ( win32-handle -- win32-handle )
  88     dup handle>> master-completion-port get-global <completion-port> drop ;
  89
  90 : eof? ( error -- ? )
  91     { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
  92
  93 : twiddle-thumbs ( overlapped port -- bytes-transferred )
  94     [
  95         drop
  96         [ self ] dip >c-ptr pending-overlapped get-global set-at
  97         "I/O" suspend {
  98             { [ dup integer? ] [ ] }
  99             { [ dup array? ] [
 100                 first dup eof?
 101                 [ drop 0 ] [ n>win32-error-string throw ] if
 102             ] }
 103         } cond
 104     ] with-timeout ;
 105
 106 :: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
 107     nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
 108     master-completion-port get-global
 109     { int void* pointer: OVERLAPPED }
 110     [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
 111     :> ( error? bytes key overlapped )
 112     bytes overlapped error? ;
 113
 114 : resume-callback ( result overlapped -- )
 115     >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
 116
 117 : handle-overlapped ( nanos -- ? )
 118     wait-for-overlapped [
 119         [
 120             [ drop GetLastError 1array ] dip resume-callback t
 121         ] [ drop f ] if*
 122     ] [ resume-callback t ] if ;
 123
 124 M: win32-handle cancel-operation
 125     [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
 126
 127 M: windows io-multiplex ( nanos -- )
 128     handle-overlapped [ 0 io-multiplex ] when ;
 129
 130 M: windows init-io ( -- )
 131     <master-completion-port> master-completion-port set-global
 132     H{ } clone pending-overlapped set-global ;
 133
 134 ERROR: invalid-file-size n ;
 135
 136 : (handle>file-size) ( handle -- n/f )
 137     0 ulonglong <ref> [ GetFileSizeEx ] keep swap
 138     [ drop f ] [ drop ulonglong deref ] if-zero ;
 139
 140 ! GetFileSizeEx errors with ERROR_INVALID_FUNCTION if handle is not seekable
 141 : handle>file-size ( handle -- n/f )
 142     (handle>file-size) [
 143         GetLastError ERROR_INVALID_FUNCTION =
 144         [ f ] [ throw-win32-error ] if
 145     ] unless* ;
 146
 147 ERROR: seek-before-start n ;
 148
 149 : set-seek-ptr ( n handle -- )
 150     [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
 151
 152 M: windows tell-handle ( handle -- n ) ptr>> ;
 153
 154 M: windows seek-handle ( n seek-type handle -- )
 155     swap {
 156         { seek-absolute [ set-seek-ptr ] }
 157         { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
 158         { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
 159         [ bad-seek-type ]
 160     } case ;
 161
 162 M: windows can-seek-handle? ( handle -- ? )
 163     handle>> handle>file-size >boolean ;
 164
 165 M: windows handle-length ( handle -- n/f )
 166     handle>> handle>file-size
 167     dup { 0 f } member? [ drop f ] when ;
 168
 169 : file-error? ( n -- eof? )
 170     zero? [
 171         GetLastError {
 172             { [ dup expected-io-error? ] [ drop f ] }
 173             { [ dup eof? ] [ drop t ] }
 174             [ n>win32-error-string throw ]
 175         } cond
 176     ] [ f ] if ;
 177
 178 : wait-for-file ( FileArgs n port -- n )
 179     swap file-error?
 180     [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
 181
 182 : update-file-ptr ( n port -- )
 183     handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
 184
 185 : finish-write ( n port -- )
 186     [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
 187
 188 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
 189     {
 190         [ hFile>> ]
 191         [ lpBuffer>> buffer-end ]
 192         [ lpBuffer>> buffer-capacity ]
 193         [ lpNumberOfBytesRet>> ]
 194         [ lpOverlapped>> ]
 195     } cleave ;
 196
 197 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
 198     {
 199         [ hFile>> ]
 200         [ lpBuffer>> buffer@ ]
 201         [ lpBuffer>> buffer-length ]
 202         [ lpNumberOfBytesRet>> ]
 203         [ lpOverlapped>> ]
 204     } cleave ;
 205
 206 M: windows (wait-to-write)
 207     [
 208         [ make-FileArgs dup setup-write WriteFile ]
 209         [ wait-for-file ]
 210         [ finish-write ]
 211         tri
 212     ] with-destructors ;
 213
 214 : finish-read ( n port -- )
 215     [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
 216
 217 M: windows (wait-to-read) ( port -- )
 218     [
 219         [ make-FileArgs dup setup-read ReadFile ]
 220         [ wait-for-file ]
 221         [ finish-read ]
 222         tri
 223     ] with-destructors ;
 224
 225 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
 226
 227 M: windows init-stdio
 228     console-app?
 229     [ init-c-stdio ]
 230     [ null-reader null-writer null-writer set-stdio ] if ;
 231
 232 : open-file ( path access-mode create-mode flags -- handle )
 233     [
 234         [ share-mode default-security-attributes ] 2dip
 235         CreateFile-flags f CreateFile opened-file
 236     ] with-destructors ;
 237
 238 : open-r/w ( path -- win32-file )
 239     flags{ GENERIC_READ GENERIC_WRITE }
 240     OPEN_EXISTING 0 open-file ;
 241
 242 : open-read ( path -- win32-file )
 243     GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
 244
 245 : open-write ( path -- win32-file )
 246     GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
 247
 248 : (open-append) ( path -- win32-file )
 249     GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
 250
 251 : open-existing ( path -- win32-file )
 252     flags{ GENERIC_READ GENERIC_WRITE }
 253     share-mode
 254     f
 255     OPEN_EXISTING
 256     FILE_FLAG_BACKUP_SEMANTICS
 257     f CreateFileW dup win32-error=0/f <win32-file> ;
 258
 259 : maybe-create-file ( path -- win32-file ? )
 260     #! return true if file was just created
 261     flags{ GENERIC_READ GENERIC_WRITE }
 262     share-mode
 263     f
 264     OPEN_ALWAYS
 265     0 CreateFile-flags
 266     f CreateFileW dup win32-error=0/f <win32-file>
 267     GetLastError ERROR_ALREADY_EXISTS = not ;
 268
 269 : set-file-pointer ( handle length method -- )
 270     [ [ handle>> ] dip d>w/w uint <ref> ] dip SetFilePointer
 271     INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
 272
 273 M: windows (file-reader) ( path -- stream )
 274     open-read <input-port> ;
 275
 276 M: windows (file-writer) ( path -- stream )
 277     open-write <output-port> ;
 278
 279 M: windows (file-appender) ( path -- stream )
 280     open-append <output-port> ;
 281
 282 SYMBOLS: +read-only+ +hidden+ +system+
 283 +archive+ +device+ +normal+ +temporary+
 284 +sparse-file+ +reparse-point+ +compressed+ +offline+
 285 +not-content-indexed+ +encrypted+ ;
 286
 287 SLOT: attributes
 288
 289 : read-only? ( file-info -- ? )
 290     attributes>> +read-only+ swap member? ;
 291
 292 : set-file-attributes ( path flags -- )
 293     SetFileAttributes win32-error=0/f ;
 294
 295 : set-file-normal-attribute ( path -- )
 296     FILE_ATTRIBUTE_NORMAL set-file-attributes ;
 297
 298 : win32-file-attribute ( n symbol attr -- )
 299     rot mask? [ , ] [ drop ] if ;
 300
 301 : win32-file-attributes ( n -- seq )
 302     [
 303         {
 304             [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
 305             [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
 306             [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
 307             [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
 308             [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
 309             [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
 310             [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
 311             [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
 312             [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
 313             [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
 314             [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
 315             [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
 316             [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
 317             [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
 318         } cleave
 319     ] { } make ;
 320
 321 : win32-file-type ( n -- symbol )
 322     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 323
 324 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
 325     [ timestamp>FILETIME ] tri@
 326     SetFileTime win32-error=0/f ;
 327
 328 M: windows cwd
 329     MAX_UNICODE_PATH dup ushort <c-array>
 330     [ GetCurrentDirectory win32-error=0/f ] keep alien>native-string ;
 331
 332 M: windows cd
 333     SetCurrentDirectory win32-error=0/f ;
 334
 335 CONSTANT: unicode-prefix "\\\\?\\"
 336
 337 M: windows root-directory? ( path -- ? )
 338     {
 339         { [ dup empty? ] [ drop f ] }
 340         { [ dup [ path-separator? ] all? ] [ drop t ] }
 341         { [ dup trim-tail-separators { [ length 2 = ]
 342           [ second CHAR: : = ] } 1&& ] [ drop t ] }
 343         { [ dup unicode-prefix head? ]
 344           [ trim-tail-separators length unicode-prefix length 2 + = ] }
 345         [ drop f ]
 346     } cond ;
 347
 348 : prepend-prefix ( string -- string' )
 349     dup unicode-prefix head? [
 350         unicode-prefix prepend
 351     ] unless ;
 352
 353 TR: normalize-separators "/" "\\" ;
 354
 355 <PRIVATE
 356
 357 : unc-path? ( string -- ? )
 358     [ "//" head? ] [ "\\\\" head? ] bi or ;
 359
 360 PRIVATE>
 361
 362 M: windows normalize-path ( string -- string' )
 363     dup unc-path? [
 364         normalize-separators
 365     ] [
 366         absolute-path
 367         normalize-separators
 368         prepend-prefix
 369     ] if ;
 370
 371 M: windows CreateFile-flags ( DWORD -- DWORD )
 372     FILE_FLAG_OVERLAPPED bitor ;
 373
 374 <PRIVATE
 375
 376 : windows-file-size ( path -- size )
 377     normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
 378     [ GetFileAttributesEx win32-error=0/f ] keep
 379     [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
 380
 381 PRIVATE>
 382
 383 M: windows open-append
 384     [ dup windows-file-size ] [ drop 0 ] recover
 385     [ (open-append) ] dip >>ptr ;
 386
 387 M: windows home
 388     {
 389         [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
 390         [ "USERPROFILE" os-env ]
 391         [ my-documents ]
 392     } 0|| ;