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