factor/basis/io/launcher/windows/windows.factor

165 lines
5.0 KiB
Factor
Raw Normal View History

! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
2008-04-04 13:02:25 -04:00
USING: alien alien.c-types arrays continuations io
2008-12-13 05:41:33 -05:00
io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports
windows.types math windows.kernel32
2008-09-11 02:27:23 -04:00
namespaces make io.launcher kernel sequences windows.errors
2008-02-18 08:30:16 -05:00
splitting system threads init strings combinators
2008-04-04 13:02:25 -04:00
io.backend accessors concurrency.flags io.files assocs
2008-11-14 21:18:16 -05:00
io.files.private windows destructors specialized-arrays.ushort
specialized-arrays.alien ;
IN: io.launcher.windows
2007-09-20 18:09:08 -04:00
TUPLE: CreateProcess-args
lpApplicationName
lpCommandLine
lpProcessAttributes
lpThreadAttributes
bInheritHandles
dwCreateFlags
lpEnvironment
lpCurrentDirectory
lpStartupInfo
2008-05-15 02:45:32 -04:00
lpProcessInformation ;
: default-CreateProcess-args ( -- obj )
CreateProcess-args new
2007-09-20 18:09:08 -04:00
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
2008-03-26 19:47:56 -04:00
TRUE >>bInheritHandles
2008-04-03 18:04:23 -04:00
0 >>dwCreateFlags ;
2007-09-20 18:09:08 -04:00
: call-CreateProcess ( CreateProcess-args -- )
{
[ lpApplicationName>> ]
[ lpCommandLine>> ]
[ lpProcessAttributes>> ]
[ lpThreadAttributes>> ]
[ bInheritHandles>> ]
[ dwCreateFlags>> ]
[ lpEnvironment>> ]
[ lpCurrentDirectory>> ]
[ lpStartupInfo>> ]
[ lpProcessInformation>> ]
} cleave
CreateProcess win32-error=0/f ;
2007-09-20 18:09:08 -04:00
2008-04-06 01:53:50 -04:00
: count-trailing-backslashes ( str n -- str n )
[ "\\" ?tail ] dip swap [
2008-08-27 12:52:46 -04:00
1+ count-trailing-backslashes
] when ;
2008-04-06 01:53:50 -04:00
: fix-trailing-backslashes ( str -- str' )
0 count-trailing-backslashes
2 * CHAR: \\ <repetition> append ;
2007-11-24 18:05:34 -05:00
: escape-argument ( str -- newstr )
2008-04-06 01:53:50 -04:00
CHAR: \s over member? [
2008-12-06 19:58:45 -05:00
fix-trailing-backslashes "\"" dup surround
2008-04-06 01:53:50 -04:00
] when ;
2007-11-24 18:05:34 -05:00
2007-11-17 23:06:51 -05:00
: join-arguments ( args -- cmd-line )
2008-02-03 15:23:14 -05:00
[ escape-argument ] map " " join ;
2007-11-17 23:06:51 -05:00
2008-03-26 16:55:55 -04:00
: lookup-priority ( process -- n )
priority>> {
{ +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
{ +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
{ +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
{ +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
{ +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
{ +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
[ drop f ]
} case ;
: app-name/cmd-line ( process -- app-name cmd-line )
command>> dup string? [
2007-11-17 23:06:51 -05:00
" " split1
] [
unclip swap join-arguments
] if ;
2007-11-17 23:06:51 -05:00
: cmd-line ( process -- cmd-line )
command>> dup string? [ join-arguments ] unless ;
2007-11-17 23:06:51 -05:00
: fill-lpApplicationName ( process args -- process args )
over app-name/cmd-line
[ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
2007-11-17 23:06:51 -05:00
: fill-lpCommandLine ( process args -- process args )
over cmd-line >>lpCommandLine ;
: fill-dwCreateFlags ( process args -- process args )
2007-11-17 23:06:51 -05:00
0
pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
2008-04-02 19:25:33 -04:00
pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
2008-03-26 16:55:55 -04:00
pick lookup-priority [ bitor ] when*
>>dwCreateFlags ;
: fill-lpEnvironment ( process args -- process args )
over pass-environment? [
[
over get-environment
[ swap % "=" % % "\0" % ] assoc-each
"\0" %
] ushort-array{ } make
>>lpEnvironment
] when ;
: fill-startup-info ( process args -- process args )
STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
2008-01-25 00:49:03 -05:00
HOOK: fill-redirection io-backend ( process args -- )
2008-01-25 00:49:03 -05:00
2008-04-02 21:09:56 -04:00
M: wince fill-redirection 2drop ;
2008-01-25 00:49:03 -05:00
: make-CreateProcess-args ( process -- args )
default-CreateProcess-args
2008-04-02 19:25:33 -04:00
os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
fill-dwCreateFlags
2008-02-14 03:20:20 -05:00
fill-lpEnvironment
fill-startup-info
nip ;
2008-04-02 21:09:56 -04:00
M: windows current-process-handle ( -- handle )
GetCurrentProcessId ;
2008-04-02 21:09:56 -04:00
M: windows run-process* ( process -- handle )
2007-09-20 18:09:08 -04:00
[
2008-04-04 23:40:37 -04:00
current-directory get (normalize-path) cd
dup make-CreateProcess-args
tuck fill-redirection
dup call-CreateProcess
lpProcessInformation>>
2008-01-25 00:49:03 -05:00
] with-destructors ;
2008-04-02 21:09:56 -04:00
M: windows kill-process* ( handle -- )
2008-02-03 15:23:14 -05:00
PROCESS_INFORMATION-hProcess
255 TerminateProcess win32-error=0/f ;
: dispose-process ( process-information -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."
dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
: exit-code ( process -- n )
PROCESS_INFORMATION-hProcess
0 <ulong> [ GetExitCodeProcess ] keep *ulong
swap win32-error=0/f ;
: process-exited ( process -- )
2008-09-02 14:42:05 -04:00
dup handle>> exit-code
over handle>> dispose-process
2008-03-06 21:44:52 -05:00
notify-exit ;
M: windows wait-for-processes ( -- ? )
processes get keys dup
2008-11-14 21:18:16 -05:00
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
[ length ] keep 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;