1 ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types combinators destructors
4 io.backend io.backend.windows io.files.windows io.launcher
5 io.launcher.windows io.pipes io.ports kernel locals strings
6 system windows.errors windows.handles windows.kernel32
8 IN: io.launcher.windows.nt
10 : duplicate-handle ( handle -- handle' )
11 GetCurrentProcess ! source process
12 swap handle>> ! handle
13 GetCurrentProcess ! target process
14 f <void*> [ ! target handle
15 DUPLICATE_SAME_ACCESS ! desired access
18 DuplicateHandle win32-error=0/f
19 ] keep *void* <win32-handle> &dispose ;
21 ! /dev/null simulation
22 : null-input ( -- pipe )
23 (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
25 : null-output ( -- pipe )
26 (pipe) [ in>> dispose ] [ out>> &dispose ] bi ;
28 : null-pipe ( mode -- pipe )
30 { GENERIC_READ [ null-input ] }
31 { GENERIC_WRITE [ null-output ] }
34 ! The below code is based on the example given in
35 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
37 : redirect-default ( obj access-mode create-mode -- handle )
40 : redirect-closed ( obj access-mode create-mode -- handle )
43 :: redirect-file ( path access-mode create-mode -- handle )
47 default-security-attributes
49 FILE_ATTRIBUTE_NORMAL ! flags and attributes
51 CreateFile dup invalid-handle? <win32-file> &dispose ;
53 : redirect-append ( path access-mode create-mode -- handle )
57 dup 0 FILE_END set-file-pointer ;
59 : redirect-handle ( handle access-mode create-mode -- handle )
62 : redirect-stream ( stream access-mode create-mode -- handle )
63 [ underlying-handle ] 2dip redirect-handle ;
65 : redirect ( obj access-mode create-mode -- handle )
67 { [ pick not ] [ redirect-default ] }
68 { [ pick +closed+ eq? ] [ redirect-closed ] }
69 { [ pick string? ] [ redirect-file ] }
70 { [ pick appender? ] [ redirect-append ] }
71 { [ pick win32-file? ] [ redirect-handle ] }
74 dup [ dup t set-inherit handle>> ] when ;
76 : redirect-stdout ( process args -- handle )
82 STD_OUTPUT_HANDLE GetStdHandle or ;
84 : redirect-stderr ( process args -- handle )
85 over stderr>> +stdout+ eq? [
87 lpStartupInfo>> hStdOutput>>
94 STD_ERROR_HANDLE GetStdHandle or
97 : redirect-stdin ( process args -- handle )
103 STD_INPUT_HANDLE GetStdHandle or ;
105 M: winnt fill-redirection ( process args -- )
107 [ [ redirect-stdout ] dip hStdOutput<< ]
108 [ [ redirect-stderr ] dip hStdError<< ]
109 [ [ redirect-stdin ] dip hStdInput<< ] 3tri ;