basis/io/files/windows/windows.factor

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