basis/io/launcher/windows/windows.factor

   1 ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.c-types arrays continuations io
   4 io.backend.windows io.pipes.windows.nt io.pathnames libc io.ports
   5 windows.types math windows.kernel32
   6 namespaces make io.launcher kernel sequences windows.errors
   7 splitting system threads init strings combinators
   8 io.backend accessors concurrency.flags io.files assocs
   9 io.files.private windows destructors specialized-arrays.ushort
  10 specialized-arrays.alien ;
  11 IN: io.launcher.windows
  12
  13 TUPLE: CreateProcess-args
  14        lpApplicationName
  15        lpCommandLine
  16        lpProcessAttributes
  17        lpThreadAttributes
  18        bInheritHandles
  19        dwCreateFlags
  20        lpEnvironment
  21        lpCurrentDirectory
  22        lpStartupInfo
  23        lpProcessInformation ;
  24
  25 : default-CreateProcess-args ( -- obj )
  26     CreateProcess-args new
  27     "STARTUPINFO" <c-object>
  28     "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
  29     "PROCESS_INFORMATION" <c-object> >>lpProcessInformation
  30     TRUE >>bInheritHandles
  31     0 >>dwCreateFlags ;
  32
  33 : call-CreateProcess ( CreateProcess-args -- )
  34     {
  35         [ lpApplicationName>> ]
  36         [ lpCommandLine>> ]
  37         [ lpProcessAttributes>> ]
  38         [ lpThreadAttributes>> ]
  39         [ bInheritHandles>> ]
  40         [ dwCreateFlags>> ]
  41         [ lpEnvironment>> ]
  42         [ lpCurrentDirectory>> ]
  43         [ lpStartupInfo>> ]
  44         [ lpProcessInformation>> ]
  45     } cleave
  46     CreateProcess win32-error=0/f ;
  47
  48 : count-trailing-backslashes ( str n -- str n )
  49     [ "\\" ?tail ] dip swap [
  50         1 + count-trailing-backslashes
  51     ] when ;
  52
  53 : fix-trailing-backslashes ( str -- str' )
  54     0 count-trailing-backslashes
  55     2 * CHAR: \\ <repetition> append ;
  56
  57 : escape-argument ( str -- newstr )
  58     CHAR: \s over member? [
  59         fix-trailing-backslashes "\"" dup surround
  60     ] when ;
  61
  62 : join-arguments ( args -- cmd-line )
  63     [ escape-argument ] map " " join ;
  64
  65 : lookup-priority ( process -- n )
  66     priority>> {
  67         { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
  68         { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
  69         { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
  70         { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
  71         { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
  72         { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
  73         [ drop f ]
  74     } case ;
  75
  76 : app-name/cmd-line ( process -- app-name cmd-line )
  77     command>> dup string? [
  78         " " split1
  79     ] [
  80         unclip swap join-arguments
  81     ] if ;
  82
  83 : cmd-line ( process -- cmd-line )
  84     command>> dup string? [ join-arguments ] unless ;
  85
  86 : fill-lpApplicationName ( process args -- process args )
  87     over app-name/cmd-line
  88     [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
  89
  90 : fill-lpCommandLine ( process args -- process args )
  91     over cmd-line >>lpCommandLine ;
  92
  93 : fill-dwCreateFlags ( process args -- process args )
  94     0
  95     pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
  96     pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
  97     pick lookup-priority [ bitor ] when*
  98     >>dwCreateFlags ;
  99
 100 : fill-lpEnvironment ( process args -- process args )
 101     over pass-environment? [
 102         [
 103             over get-environment
 104             [ swap % "=" % % "\0" % ] assoc-each
 105             "\0" %
 106         ] ushort-array{ } make
 107         >>lpEnvironment
 108     ] when ;
 109
 110 : fill-startup-info ( process args -- process args )
 111     STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
 112
 113 HOOK: fill-redirection io-backend ( process args -- )
 114
 115 M: wince fill-redirection 2drop ;
 116
 117 : make-CreateProcess-args ( process -- args )
 118     default-CreateProcess-args
 119     os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
 120     fill-dwCreateFlags
 121     fill-lpEnvironment
 122     fill-startup-info
 123     nip ;
 124
 125 M: windows current-process-handle ( -- handle )
 126     GetCurrentProcessId ;
 127
 128 M: windows run-process* ( process -- handle )
 129     [
 130         current-directory get (normalize-path) cd
 131
 132         dup make-CreateProcess-args
 133         tuck fill-redirection
 134         dup call-CreateProcess
 135         lpProcessInformation>>
 136     ] with-destructors ;
 137
 138 M: windows kill-process* ( handle -- )
 139     PROCESS_INFORMATION-hProcess
 140     255 TerminateProcess win32-error=0/f ;
 141
 142 : dispose-process ( process-information -- )
 143     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
 144     #! with CloseHandle when they are no longer needed."
 145     dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
 146     PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
 147
 148 : exit-code ( process -- n )
 149     PROCESS_INFORMATION-hProcess
 150     0 <ulong> [ GetExitCodeProcess ] keep *ulong
 151     swap win32-error=0/f ;
 152
 153 : process-exited ( process -- )
 154     dup handle>> exit-code
 155     over handle>> dispose-process
 156     notify-exit ;
 157
 158 M: windows wait-for-processes ( -- ? )
 159     processes get keys dup
 160     [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
 161     [ length ] keep 0 0
 162     WaitForMultipleObjects
 163     dup HEX: ffffffff = [ win32-error ] when
 164     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;