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 )
 137     0 ulonglong <ref> [ GetFileSizeEx win32-error=0/f ] keep ulonglong deref ;
 138
 139 ! Returns T{ windows-error f 1 "Incorrect function." } if stream is not seekable
 140 : handle>file-size ( handle -- n/f )
 141     '[ _ (handle>file-size) ]
 142      [ dup n>> 1 = [ drop f ] [ rethrow ] if ] recover ;
 143
 144 ERROR: seek-before-start n ;
 145
 146 : set-seek-ptr ( n handle -- )
 147     [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
 148
 149 M: windows tell-handle ( handle -- n ) ptr>> ;
 150
 151 M: windows seek-handle ( n seek-type handle -- )
 152     swap {
 153         { seek-absolute [ set-seek-ptr ] }
 154         { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
 155         { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
 156         [ bad-seek-type ]
 157     } case ;
 158
 159 M: windows can-seek-handle? ( handle -- ? )
 160     handle>> handle>file-size >boolean ;
 161
 162 M: windows handle-length ( handle -- n/f )
 163     handle>> handle>file-size
 164     dup { 0 f } member? [ drop f ] when ;
 165
 166 : file-error? ( n -- eof? )
 167     zero? [
 168         GetLastError {
 169             { [ dup expected-io-error? ] [ drop f ] }
 170             { [ dup eof? ] [ drop t ] }
 171             [ n>win32-error-string throw ]
 172         } cond
 173     ] [ f ] if ;
 174
 175 : wait-for-file ( FileArgs n port -- n )
 176     swap file-error?
 177     [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
 178
 179 : update-file-ptr ( n port -- )
 180     handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
 181
 182 : finish-write ( n port -- )
 183     [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
 184
 185 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
 186     {
 187         [ hFile>> ]
 188         [ lpBuffer>> buffer-end ]
 189         [ lpBuffer>> buffer-capacity ]
 190         [ lpNumberOfBytesRet>> ]
 191         [ lpOverlapped>> ]
 192     } cleave ;
 193
 194 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
 195     {
 196         [ hFile>> ]
 197         [ lpBuffer>> buffer@ ]
 198         [ lpBuffer>> buffer-length ]
 199         [ lpNumberOfBytesRet>> ]
 200         [ lpOverlapped>> ]
 201     } cleave ;
 202
 203 M: windows (wait-to-write)
 204     [
 205         [ make-FileArgs dup setup-write WriteFile ]
 206         [ wait-for-file ]
 207         [ finish-write ]
 208         tri
 209     ] with-destructors ;
 210
 211 : finish-read ( n port -- )
 212     [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
 213
 214 M: windows (wait-to-read) ( port -- )
 215     [
 216         [ make-FileArgs dup setup-read ReadFile ]
 217         [ wait-for-file ]
 218         [ finish-read ]
 219         tri
 220     ] with-destructors ;
 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 CreateFile 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 : open-existing ( path -- win32-file )
 249     flags{ GENERIC_READ GENERIC_WRITE }
 250     share-mode
 251     f
 252     OPEN_EXISTING
 253     FILE_FLAG_BACKUP_SEMANTICS
 254     f CreateFileW dup win32-error=0/f <win32-file> ;
 255
 256 : maybe-create-file ( path -- win32-file ? )
 257     #! return true if file was just created
 258     flags{ GENERIC_READ GENERIC_WRITE }
 259     share-mode
 260     f
 261     OPEN_ALWAYS
 262     0 CreateFile-flags
 263     f CreateFileW dup win32-error=0/f <win32-file>
 264     GetLastError ERROR_ALREADY_EXISTS = not ;
 265
 266 : set-file-pointer ( handle length method -- )
 267     [ [ handle>> ] dip d>w/w uint <ref> ] dip SetFilePointer
 268     INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
 269
 270 M: windows (file-reader) ( path -- stream )
 271     open-read <input-port> ;
 272
 273 M: windows (file-writer) ( path -- stream )
 274     open-write <output-port> ;
 275
 276 M: windows (file-appender) ( path -- stream )
 277     open-append <output-port> ;
 278
 279 SYMBOLS: +read-only+ +hidden+ +system+
 280 +archive+ +device+ +normal+ +temporary+
 281 +sparse-file+ +reparse-point+ +compressed+ +offline+
 282 +not-content-indexed+ +encrypted+ ;
 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-attribute ( n symbol attr -- )
 294     rot mask? [ , ] [ drop ] if ;
 295
 296 : win32-file-attributes ( n -- seq )
 297     [
 298         {
 299             [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
 300             [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
 301             [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
 302             [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
 303             [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
 304             [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
 305             [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
 306             [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
 307             [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
 308             [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
 309             [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
 310             [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
 311             [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
 312             [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
 313         } cleave
 314     ] { } make ;
 315
 316 : win32-file-type ( n -- symbol )
 317     FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
 318
 319 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
 320     [ timestamp>FILETIME ] tri@
 321     SetFileTime win32-error=0/f ;
 322
 323 M: windows cwd
 324     MAX_UNICODE_PATH dup ushort <c-array>
 325     [ GetCurrentDirectory win32-error=0/f ] keep
 326     utf16n alien>string ;
 327
 328 M: windows cd
 329     SetCurrentDirectory win32-error=0/f ;
 330
 331 CONSTANT: unicode-prefix "\\\\?\\"
 332
 333 M: windows root-directory? ( path -- ? )
 334     {
 335         { [ dup empty? ] [ drop f ] }
 336         { [ dup [ path-separator? ] all? ] [ drop t ] }
 337         { [ dup trim-tail-separators { [ length 2 = ]
 338           [ second CHAR: : = ] } 1&& ] [ drop t ] }
 339         { [ dup unicode-prefix head? ]
 340           [ trim-tail-separators length unicode-prefix length 2 + = ] }
 341         [ drop f ]
 342     } cond ;
 343
 344 : prepend-prefix ( string -- string' )
 345     dup unicode-prefix head? [
 346         unicode-prefix prepend
 347     ] unless ;
 348
 349 TR: normalize-separators "/" "\\" ;
 350
 351 <PRIVATE
 352
 353 : unc-path? ( string -- ? )
 354     [ "//" head? ] [ "\\\\" head? ] bi or ;
 355
 356 PRIVATE>
 357
 358 M: windows normalize-path ( string -- string' )
 359     dup unc-path? [
 360         normalize-separators
 361     ] [
 362         absolute-path
 363         normalize-separators
 364         prepend-prefix
 365     ] if ;
 366
 367 M: windows CreateFile-flags ( DWORD -- DWORD )
 368     FILE_FLAG_OVERLAPPED bitor ;
 369
 370 <PRIVATE
 371
 372 : windows-file-size ( path -- size )
 373     normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
 374     [ GetFileAttributesEx win32-error=0/f ] keep
 375     [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
 376
 377 PRIVATE>
 378
 379 M: windows open-append
 380     [ dup windows-file-size ] [ drop 0 ] recover
 381     [ (open-append) ] dip >>ptr ;
 382
 383 M: windows home
 384     {
 385         [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
 386         [ "USERPROFILE" os-env ]
 387         [ my-documents ]
 388     } 0|| ;