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