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
7 io.encodings.utf16n io.files io.files.private io.files.types
8 io.pathnames io.ports io.streams.c io.streams.null io.timeouts
9 kernel libc literals locals make math math.bitwise namespaces
10 sequences specialized-arrays system
11 threads tr windows windows.errors windows.handles
12 windows.kernel32 windows.shell32 windows.time windows.types ;
13 SPECIALIZED-ARRAY: ushort
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 )
21 TUPLE: win32-file < win32-handle ptr ;
23 : <win32-file> ( handle -- win32-file )
24 win32-file new-win32-handle ;
27 [ cancel-operation ] [ call-next-method ] bi ;
29 : opened-file ( handle -- win32-file )
30 check-invalid-handle <win32-file> |dispose add-completion ;
39 : default-security-attributes ( -- obj )
40 SECURITY_ATTRIBUTES <struct>
41 SECURITY_ATTRIBUTES heap-size >>nLength ;
44 hFile lpBuffer nNumberOfBytesToRead
45 lpNumberOfBytesRet lpOverlapped ;
47 C: <FileArgs> FileArgs
49 : make-FileArgs ( port -- <FileArgs> )
51 [ handle>> check-disposed ]
54 [ buffer>> buffer-length ]
55 [ drop DWORD <c-object> ]
56 [ FileArgs-overlapped ]
59 ! Global variable with assoc mapping overlapped to threads
60 SYMBOL: pending-overlapped
62 TUPLE: io-callback port thread ;
64 C: <io-callback> io-callback
66 : (make-overlapped) ( -- overlapped-ext )
67 OVERLAPPED malloc-struct &free ;
69 : make-overlapped ( port -- overlapped-ext )
70 [ (make-overlapped) ] dip
71 handle>> ptr>> [ >>offset ] when* ;
73 M: winnt FileArgs-overlapped ( port -- overlapped )
76 : <completion-port> ( handle existing -- handle )
77 f 1 CreateIoCompletionPort dup win32-error=0/f ;
79 SYMBOL: master-completion-port
81 : <master-completion-port> ( -- handle )
82 INVALID_HANDLE_VALUE f <completion-port> ;
84 M: winnt add-completion ( win32-handle -- win32-handle )
85 dup handle>> master-completion-port get-global <completion-port> drop ;
88 { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
90 : twiddle-thumbs ( overlapped port -- bytes-transferred )
93 [ self ] dip >c-ptr pending-overlapped get-global set-at
95 { [ dup integer? ] [ ] }
98 [ drop 0 ] [ n>win32-error-string throw ] if
103 :: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
104 nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
105 master-completion-port get-global
106 { int void* pointer: OVERLAPPED }
107 [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
108 :> ( error? bytes key overlapped )
109 bytes overlapped error? ;
111 : resume-callback ( result overlapped -- )
112 >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
114 : handle-overlapped ( nanos -- ? )
115 wait-for-overlapped [
117 [ drop GetLastError 1array ] dip resume-callback t
119 ] [ resume-callback t ] if ;
121 M: win32-handle cancel-operation
122 [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
124 M: winnt io-multiplex ( nanos -- )
125 handle-overlapped [ 0 io-multiplex ] when ;
127 M: winnt init-io ( -- )
128 <master-completion-port> master-completion-port set-global
129 H{ } clone pending-overlapped set-global ;
131 ERROR: invalid-file-size n ;
133 : handle>file-size ( handle -- n )
134 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
136 ERROR: seek-before-start n ;
138 : set-seek-ptr ( n handle -- )
139 [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
141 M: winnt tell-handle ( handle -- n ) ptr>> ;
143 M: winnt seek-handle ( n seek-type handle -- )
145 { seek-absolute [ set-seek-ptr ] }
146 { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
147 { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
151 : file-error? ( n -- eof? )
154 { [ dup expected-io-error? ] [ drop f ] }
155 { [ dup eof? ] [ drop t ] }
156 [ n>win32-error-string throw ]
160 : wait-for-file ( FileArgs n port -- n )
162 [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
164 : update-file-ptr ( n port -- )
165 handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
167 : finish-write ( n port -- )
168 [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
170 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
173 [ lpBuffer>> buffer-end ]
174 [ lpBuffer>> buffer-capacity ]
175 [ lpNumberOfBytesRet>> ]
179 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
182 [ lpBuffer>> buffer@ ]
183 [ lpBuffer>> buffer-length ]
184 [ lpNumberOfBytesRet>> ]
188 M: winnt (wait-to-write)
190 [ make-FileArgs dup setup-write WriteFile ]
196 : finish-read ( n port -- )
197 [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
199 M: winnt (wait-to-read) ( port -- )
201 [ make-FileArgs dup setup-read ReadFile ]
207 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
212 [ null-reader null-writer null-writer set-stdio ] if ;
214 : open-file ( path access-mode create-mode flags -- handle )
216 [ share-mode default-security-attributes ] 2dip
217 CreateFile-flags f CreateFile opened-file
220 : open-r/w ( path -- win32-file )
221 flags{ GENERIC_READ GENERIC_WRITE }
222 OPEN_EXISTING 0 open-file ;
224 : open-read ( path -- win32-file )
225 GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
227 : open-write ( path -- win32-file )
228 GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
230 : (open-append) ( path -- win32-file )
231 GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
233 : open-existing ( path -- win32-file )
234 flags{ GENERIC_READ GENERIC_WRITE }
238 FILE_FLAG_BACKUP_SEMANTICS
239 f CreateFileW dup win32-error=0/f <win32-file> ;
241 : maybe-create-file ( path -- win32-file ? )
242 #! return true if file was just created
243 flags{ GENERIC_READ GENERIC_WRITE }
248 f CreateFileW dup win32-error=0/f <win32-file>
249 GetLastError ERROR_ALREADY_EXISTS = not ;
251 : set-file-pointer ( handle length method -- )
252 [ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
253 INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
255 M: windows (file-reader) ( path -- stream )
256 open-read <input-port> ;
258 M: windows (file-writer) ( path -- stream )
259 open-write <output-port> ;
261 M: windows (file-appender) ( path -- stream )
262 open-append <output-port> ;
264 SYMBOLS: +read-only+ +hidden+ +system+
265 +archive+ +device+ +normal+ +temporary+
266 +sparse-file+ +reparse-point+ +compressed+ +offline+
267 +not-content-indexed+ +encrypted+ ;
269 : win32-file-attribute ( n symbol attr -- )
270 rot mask? [ , ] [ drop ] if ;
272 : win32-file-attributes ( n -- seq )
275 [ +read-only+ FILE_ATTRIBUTE_READONLY win32-file-attribute ]
276 [ +hidden+ FILE_ATTRIBUTE_HIDDEN win32-file-attribute ]
277 [ +system+ FILE_ATTRIBUTE_SYSTEM win32-file-attribute ]
278 [ +directory+ FILE_ATTRIBUTE_DIRECTORY win32-file-attribute ]
279 [ +archive+ FILE_ATTRIBUTE_ARCHIVE win32-file-attribute ]
280 [ +device+ FILE_ATTRIBUTE_DEVICE win32-file-attribute ]
281 [ +normal+ FILE_ATTRIBUTE_NORMAL win32-file-attribute ]
282 [ +temporary+ FILE_ATTRIBUTE_TEMPORARY win32-file-attribute ]
283 [ +sparse-file+ FILE_ATTRIBUTE_SPARSE_FILE win32-file-attribute ]
284 [ +reparse-point+ FILE_ATTRIBUTE_REPARSE_POINT win32-file-attribute ]
285 [ +compressed+ FILE_ATTRIBUTE_COMPRESSED win32-file-attribute ]
286 [ +offline+ FILE_ATTRIBUTE_OFFLINE win32-file-attribute ]
287 [ +not-content-indexed+ FILE_ATTRIBUTE_NOT_CONTENT_INDEXED win32-file-attribute ]
288 [ +encrypted+ FILE_ATTRIBUTE_ENCRYPTED win32-file-attribute ]
292 : win32-file-type ( n -- symbol )
293 FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
295 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
296 [ timestamp>FILETIME ] tri@
297 SetFileTime win32-error=0/f ;
300 MAX_UNICODE_PATH dup <ushort-array>
301 [ GetCurrentDirectory win32-error=0/f ] keep
302 utf16n alien>string ;
305 SetCurrentDirectory win32-error=0/f ;
307 CONSTANT: unicode-prefix "\\\\?\\"
309 M: winnt root-directory? ( path -- ? )
311 { [ dup empty? ] [ drop f ] }
312 { [ dup [ path-separator? ] all? ] [ drop t ] }
313 { [ dup trim-tail-separators { [ length 2 = ]
314 [ second CHAR: : = ] } 1&& ] [ drop t ] }
315 { [ dup unicode-prefix head? ]
316 [ trim-tail-separators length unicode-prefix length 2 + = ] }
320 : prepend-prefix ( string -- string' )
321 dup unicode-prefix head? [
322 unicode-prefix prepend
325 TR: normalize-separators "/" "\\" ;
327 M: winnt normalize-path ( string -- string' )
332 M: winnt CreateFile-flags ( DWORD -- DWORD )
333 FILE_FLAG_OVERLAPPED bitor ;
337 : windows-file-size ( path -- size )
338 normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
339 [ GetFileAttributesEx win32-error=0/f ] keep
340 [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
345 [ dup windows-file-size ] [ drop 0 ] recover
346 [ (open-append) ] dip >>ptr ;
350 [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
351 [ "USERPROFILE" os-env ]