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
18 : CreateFile-flags ( DWORD -- DWORD )
19 flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } bitor ;
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 ;
36 : default-security-attributes ( -- obj )
37 SECURITY_ATTRIBUTES new
38 SECURITY_ATTRIBUTES heap-size >>nLength ;
41 hFile lpBuffer nNumberOfBytesToRead
42 lpNumberOfBytesRet lpOverlapped ;
44 C: <FileArgs> FileArgs
46 ! Global variable with assoc mapping overlapped to threads
47 SYMBOL: pending-overlapped
49 TUPLE: io-callback port thread ;
51 C: <io-callback> io-callback
53 : <completion-port> ( handle existing -- handle )
54 f 1 CreateIoCompletionPort dup win32-error=0/f ;
56 : <master-completion-port> ( -- handle )
57 INVALID_HANDLE_VALUE f <completion-port> ;
59 SYMBOL: master-completion-port
61 : add-completion ( win32-handle -- win32-handle )
62 dup handle>> master-completion-port get-global <completion-port> drop ;
64 : opened-file ( handle -- win32-file )
65 check-invalid-handle <win32-file> |dispose add-completion ;
68 { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
70 : twiddle-thumbs ( overlapped port -- bytes-transferred )
73 [ self ] dip >c-ptr pending-overlapped get-global set-at
75 { [ dup integer? ] [ ] }
78 [ drop 0 ] [ throw-windows-error ] if
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? ;
91 : resume-callback ( result overlapped -- )
92 >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
94 : handle-overlapped ( nanos -- ? )
97 [ drop GetLastError 1array ] dip resume-callback t
99 ] [ resume-callback t ] if ;
101 M: win32-handle cancel-operation
102 [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
104 M: windows io-multiplex
105 handle-overlapped [ 0 io-multiplex ] when ;
108 <master-completion-port> master-completion-port set-global
109 H{ } clone pending-overlapped set-global ;
111 : (handle>file-size) ( handle -- n/f )
112 0 ulonglong <ref> [ GetFileSizeEx ] keep swap
113 [ drop f ] [ drop ulonglong deref ] if-zero ;
115 ! GetFileSizeEx errors with ERROR_INVALID_FUNCTION if handle is not seekable
116 : handle>file-size ( handle -- n/f )
118 GetLastError ERROR_INVALID_FUNCTION =
119 [ win32-error ] unless f
122 ERROR: seek-before-start n ;
124 : set-seek-ptr ( n handle -- )
125 [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
127 M: windows tell-handle ptr>> ;
129 M: windows seek-handle
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 ] }
137 M: windows can-seek-handle?
138 handle>> handle>file-size >boolean ;
140 M: windows handle-length
141 handle>> handle>file-size
142 dup { 0 f } member? [ drop f ] when ;
144 : file-error? ( n -- eof? )
147 { [ dup expected-io-error? ] [ drop f ] }
148 { [ dup eof? ] [ drop t ] }
149 [ throw-windows-error ]
153 : wait-for-file ( FileArgs n port -- n )
155 [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
157 : update-file-ptr ( n port -- )
158 handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
160 : (make-overlapped) ( -- overlapped-ext )
161 OVERLAPPED malloc-struct &free ;
163 : make-overlapped ( handle -- overlapped-ext )
164 (make-overlapped) swap
165 ptr>> [ [ 32 bits >>offset ] [ -32 shift >>offset-high ] bi ] when* ;
167 : make-FileArgs ( port handle -- <FileArgs> )
168 [ nip check-disposed handle>> ]
170 [ buffer>> dup buffer-length 0 DWORD <ref> ] dip make-overlapped
173 : setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
176 [ lpBuffer>> [ buffer@ ] [ buffer-length ] bi ]
177 [ lpNumberOfBytesRet>> ]
181 : finish-write ( n port -- )
182 [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
186 [ make-FileArgs dup setup-write WriteFile ]
187 [ drop [ wait-for-file ] [ finish-write ] bi ] 2bi f
190 : setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
193 [ lpBuffer>> [ buffer-end ] [ buffer-capacity ] bi ]
194 [ lpNumberOfBytesRet>> ]
198 : finish-read ( n port -- )
199 [ update-file-ptr ] [ buffer>> buffer+ ] 2bi ;
203 [ make-FileArgs dup setup-read ReadFile ]
204 [ drop [ wait-for-file ] [ finish-read ] bi ] 2bi f
207 M: windows (wait-to-write)
208 dup dup handle>> drain
209 [ dupd wait-for-port (wait-to-write) ] [ drop ] if* ;
211 M: windows (wait-to-read)
212 dup dup handle>> refill
213 [ dupd wait-for-port (wait-to-read) ] [ drop ] if* ;
215 : make-fd-set ( socket -- fd_set )
216 fd_set new swap 1array void* >c-array >>fd_array 1 >>fd_count ;
218 : select-sets ( socket event -- read-fds write-fds except-fds )
219 [ make-fd-set ] dip +input+ = [ f f ] [ f swap f ] if ;
221 CONSTANT: select-timeval S{ timeval { sec 0 } { usec 1000 } }
223 M: windows wait-for-fd
224 [ file>> handle>> 1 swap ] dip select-sets select-timeval
227 : console-app? ( -- ? ) GetConsoleWindow >boolean ;
229 M: windows init-stdio
232 [ null-reader null-writer null-writer set-stdio ] if ;
234 : open-file ( path access-mode create-mode flags -- handle )
236 [ share-mode default-security-attributes ] 2dip
237 CreateFile-flags f CreateFileW opened-file
240 : open-r/w ( path -- win32-file )
241 flags{ GENERIC_READ GENERIC_WRITE }
242 OPEN_EXISTING 0 open-file ;
244 : open-read ( path -- win32-file )
245 GENERIC_READ OPEN_EXISTING 0 open-file 0 >>ptr ;
247 : open-write ( path -- win32-file )
248 GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 >>ptr ;
250 : open-secure-write ( path -- win32-file )
251 GENERIC_WRITE CREATE_NEW FILE_ATTRIBUTE_TEMPORARY open-file 0 >>ptr ;
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 ;
262 : open-append ( path -- win32-file )
263 [ dup windows-file-size ] [ drop 0 ] recover
264 [ GENERIC_WRITE OPEN_ALWAYS 0 open-file ] dip >>ptr ;
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 ;
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 ;
276 : set-end-of-file ( win32-file -- )
277 handle>> SetEndOfFile [ win32-error ] unless ;
279 M: windows (file-reader)
280 open-read <input-port> ;
282 M: windows (file-writer)
283 open-write <output-port> ;
285 M: windows (file-writer-secure)
286 open-secure-write <output-port> ;
288 M: windows (file-appender)
289 open-append <output-port> ;
291 SYMBOLS: +read-only+ +hidden+ +system+
292 +archive+ +device+ +normal+ +temporary+
293 +sparse-file+ +reparse-point+ +compressed+ +offline+
294 +not-content-indexed+ +encrypted+ ;
298 : read-only? ( file-info -- ? )
299 attributes>> +read-only+ swap member? ;
301 : set-file-attributes ( path flags -- )
302 SetFileAttributes win32-error=0/f ;
304 : set-file-normal-attribute ( path -- )
305 FILE_ATTRIBUTE_NORMAL set-file-attributes ;
307 : win32-file-attributes ( n -- seq )
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 ;
325 : win32-file-type ( n -- symbol )
326 FILE_ATTRIBUTE_DIRECTORY mask? +directory+ +regular-file+ ? ;
328 : (set-file-times) ( handle timestamp/f timestamp/f timestamp/f -- )
329 [ timestamp>FILETIME ] tri@
330 SetFileTime win32-error=0/f ;
333 MAX_UNICODE_PATH dup ushort <c-array>
334 [ GetCurrentDirectory win32-error=0/f ] keep alien>native-string ;
337 SetCurrentDirectory win32-error=0/f ;
339 CONSTANT: unicode-prefix "\\\\?\\"
341 M: windows root-directory?
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 + = ] }
352 : prepend-unicode-prefix ( string -- string' )
353 dup unicode-prefix head? [
354 unicode-prefix prepend
357 : remove-unicode-prefix ( string -- string' )
358 unicode-prefix ?head drop ;
360 TR: normalize-separators "/" "\\" ;
364 : unc-path? ( string -- ? )
365 [ "//" head? ] [ "\\\\" head? ] bi or ;
369 M: windows canonicalize-path
370 remove-unicode-prefix canonicalize-path* ;
372 M: windows canonicalize-drive
373 dup windows-absolute-path? [ ":" split1 [ >upper ] dip ":" glue ] when ;
375 M: windows canonicalize-path-full canonicalize-path canonicalize-drive >windows-path ;
377 M: windows root-path remove-unicode-prefix root-path* ;
379 M: windows relative-path remove-unicode-prefix relative-path* ;
381 M: windows normalize-path
387 prepend-unicode-prefix
393 [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
394 [ "USERPROFILE" os-env ]
398 : STREAM_DATA>out ( WIN32_FIND_STREAM_DATA -- pair/f )
399 [ cStreamName>> alien>native-string ]
400 [ StreamSize>> ] bi 2array ;
402 : file-streams-rest ( streams handle -- streams )
403 WIN32_FIND_STREAM_DATA new
404 [ FindNextStream ] 2keep
406 GetLastError ERROR_HANDLE_EOF = [ win32-error ] unless
409 pick push file-streams-rest
412 : file-streams ( path -- streams )
414 FindStreamInfoStandard
415 WIN32_FIND_STREAM_DATA new
417 [ FindFirstStream ] keepd
418 over INVALID_HANDLE_VALUE = [
421 1vector swap file-streams-rest
424 : alternate-file-streams ( path -- streams )
425 file-streams [ cStreamName>> alien>native-string "::$DATA" = ] reject ;
427 : alternate-file-streams? ( path -- ? )
428 alternate-file-streams empty? not ;