basis/io/launcher/windows/windows.factor

   1 ! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types alien.data arrays assocs
   4 classes classes.struct combinators concurrency.flags
   5 continuations debugger destructors init io io.backend
   6 io.backend.windows io.files io.files.private io.files.windows
   7 io.launcher io.pathnames io.pipes io.pipes.windows io.ports
   8 kernel libc locals make math namespaces prettyprint sequences
   9 specialized-arrays splitting
  10 strings system threads windows windows.errors windows.handles
  11 windows.kernel32 windows.types ;
  12 SPECIALIZED-ARRAY: ushort
  13 SPECIALIZED-ARRAY: void*
  14 IN: io.launcher.windows
  15
  16 TUPLE: CreateProcess-args
  17        lpApplicationName
  18        lpCommandLine
  19        lpProcessAttributes
  20        lpThreadAttributes
  21        bInheritHandles
  22        dwCreateFlags
  23        lpEnvironment
  24        lpCurrentDirectory
  25        lpStartupInfo
  26        lpProcessInformation ;
  27
  28 : default-CreateProcess-args ( -- obj )
  29     CreateProcess-args new
  30         STARTUPINFO <struct>
  31         dup class heap-size >>cb
  32     >>lpStartupInfo
  33     PROCESS_INFORMATION <struct> >>lpProcessInformation
  34     TRUE >>bInheritHandles
  35     0 >>dwCreateFlags ;
  36
  37 : call-CreateProcess ( CreateProcess-args -- )
  38     {
  39         [ lpApplicationName>> ]
  40         [ lpCommandLine>> ]
  41         [ lpProcessAttributes>> ]
  42         [ lpThreadAttributes>> ]
  43         [ bInheritHandles>> ]
  44         [ dwCreateFlags>> ]
  45         [ lpEnvironment>> ]
  46         [ lpCurrentDirectory>> ]
  47         [ lpStartupInfo>> ]
  48         [ lpProcessInformation>> ]
  49     } cleave
  50     CreateProcess win32-error=0/f ;
  51
  52 : count-trailing-backslashes ( str n -- str n )
  53     [ "\\" ?tail ] dip swap [
  54         1 + count-trailing-backslashes
  55     ] when ;
  56
  57 : fix-trailing-backslashes ( str -- str' )
  58     0 count-trailing-backslashes
  59     2 * CHAR: \\ <repetition> append ;
  60
  61 : escape-double-quote ( str -- newstr )
  62     "\"" split "\\\"" join ;
  63
  64 : escape-argument ( str -- newstr )
  65     escape-double-quote
  66     CHAR: \s over member? [
  67         fix-trailing-backslashes "\"" dup surround
  68     ] when ;
  69
  70 : join-arguments ( args -- cmd-line )
  71     [ escape-argument ] map " " join ;
  72
  73 : lookup-priority ( process -- n )
  74     priority>> {
  75         { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
  76         { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
  77         { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
  78         { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
  79         { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
  80         { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
  81         [ drop f ]
  82     } case ;
  83
  84 : cmd-line ( process -- cmd-line )
  85     command>> dup string? [ join-arguments ] unless ;
  86
  87 : fill-lpCommandLine ( process args -- process args )
  88     over cmd-line >>lpCommandLine ;
  89
  90 : fill-dwCreateFlags ( process args -- process args )
  91     0
  92     pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
  93     pick detached>> os windows? and [ DETACHED_PROCESS bitor ] when
  94     pick lookup-priority [ bitor ] when*
  95     >>dwCreateFlags ;
  96
  97 : fill-lpEnvironment ( process args -- process args )
  98     over pass-environment? [
  99         [
 100             over get-environment
 101             [ swap % "=" % % "\0" % ] assoc-each
 102             "\0" %
 103         ] ushort-array{ } make
 104         >>lpEnvironment
 105     ] when ;
 106
 107 : fill-startup-info ( process args -- process args )
 108     dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ;
 109
 110 : make-CreateProcess-args ( process -- args )
 111     default-CreateProcess-args
 112     fill-lpCommandLine
 113     fill-dwCreateFlags
 114     fill-lpEnvironment
 115     fill-startup-info
 116     nip ;
 117
 118 M: windows current-process-handle ( -- handle )
 119     GetCurrentProcessId ;
 120
 121 ERROR: launch-error process error ;
 122
 123 M: launch-error error.
 124     "Launching failed with error:" print
 125     dup error>> error. nl
 126     "Launch descriptor:" print nl
 127     process>> . ;
 128
 129 M: windows kill-process* ( handle -- )
 130     hProcess>> 255 TerminateProcess win32-error=0/f ;
 131
 132 : dispose-process ( process-information -- )
 133     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
 134     #! with CloseHandle when they are no longer needed."
 135     [ hProcess>> [ CloseHandle drop ] when* ]
 136     [ hThread>> [ CloseHandle drop ] when* ] bi ;
 137
 138 : exit-code ( process -- n )
 139     hProcess>>
 140     { DWORD } [ GetExitCodeProcess ] with-out-parameters
 141     swap win32-error=0/f ;
 142
 143 : process-exited ( process -- )
 144     dup handle>> exit-code
 145     over handle>> dispose-process
 146     notify-exit ;
 147
 148 M: windows wait-for-processes ( -- ? )
 149     processes get keys dup
 150     [ handle>> hProcess>> ] void*-array{ } map-as
 151     [ length ] keep 0 0
 152     WaitForMultipleObjects
 153     dup HEX: ffffffff = [ win32-error ] when
 154     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
 155
 156 : duplicate-handle ( handle -- handle' )
 157     GetCurrentProcess ! source process
 158     swap handle>> ! handle
 159     GetCurrentProcess ! target process
 160     f void* <ref> [ ! target handle
 161         DUPLICATE_SAME_ACCESS ! desired access
 162         TRUE ! inherit handle
 163         0 ! options
 164         DuplicateHandle win32-error=0/f
 165     ] keep void* deref <win32-handle> &dispose ;
 166
 167 ! /dev/null simulation
 168 : null-input ( -- pipe )
 169     (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
 170
 171 : null-output ( -- pipe )
 172     (pipe) [ out>> &dispose ] [ in>> dispose ] bi ;
 173
 174 : null-pipe ( mode -- pipe )
 175     {
 176         { GENERIC_READ [ null-input ] }
 177         { GENERIC_WRITE [ null-output ] }
 178     } case ;
 179
 180 ! The below code is based on the example given in
 181 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 182
 183 : redirect-default ( obj access-mode create-mode -- handle )
 184     3drop f ;
 185
 186 : redirect-closed ( obj access-mode create-mode -- handle )
 187     drop nip null-pipe ;
 188
 189 :: redirect-file ( path access-mode create-mode -- handle )
 190     path normalize-path
 191     access-mode
 192     share-mode
 193     default-security-attributes
 194     create-mode
 195     FILE_ATTRIBUTE_NORMAL ! flags and attributes
 196     f ! template file
 197     CreateFile check-invalid-handle <win32-file> &dispose ;
 198
 199 : redirect-append ( path access-mode create-mode -- handle )
 200     [ path>> ] 2dip
 201     drop OPEN_ALWAYS
 202     redirect-file
 203     dup 0 FILE_END set-file-pointer ;
 204
 205 : redirect-handle ( handle access-mode create-mode -- handle )
 206     2drop ;
 207
 208 : redirect-stream ( stream access-mode create-mode -- handle )
 209     [ underlying-handle ] 2dip redirect-handle ;
 210
 211 : redirect ( obj access-mode create-mode -- handle )
 212     {
 213         { [ pick not ] [ redirect-default ] }
 214         { [ pick +closed+ eq? ] [ redirect-closed ] }
 215         { [ pick string? ] [ redirect-file ] }
 216         { [ pick appender? ] [ redirect-append ] }
 217         { [ pick win32-file? ] [ redirect-handle ] }
 218         [ redirect-stream ]
 219     } cond
 220     dup [ dup t set-inherit handle>> ] when ;
 221
 222 : redirect-stdout ( process args -- handle )
 223     drop
 224     stdout>>
 225     GENERIC_WRITE
 226     CREATE_ALWAYS
 227     redirect
 228     STD_OUTPUT_HANDLE GetStdHandle or ;
 229
 230 : redirect-stderr ( process args -- handle )
 231     over stderr>> +stdout+ eq? [
 232         nip
 233         lpStartupInfo>> hStdOutput>>
 234     ] [
 235         drop
 236         stderr>>
 237         GENERIC_WRITE
 238         CREATE_ALWAYS
 239         redirect
 240         STD_ERROR_HANDLE GetStdHandle or
 241     ] if ;
 242
 243 : redirect-stdin ( process args -- handle )
 244     drop
 245     stdin>>
 246     GENERIC_READ
 247     OPEN_EXISTING
 248     redirect
 249     STD_INPUT_HANDLE GetStdHandle or ;
 250
 251 : fill-redirection ( process args -- )
 252     dup lpStartupInfo>>
 253     [ [ redirect-stdout ] dip hStdOutput<< ]
 254     [ [ redirect-stderr ] dip hStdError<< ]
 255     [ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
 256
 257 M: windows run-process* ( process -- handle )
 258     [
 259         [
 260             current-directory get absolute-path cd
 261
 262             dup make-CreateProcess-args
 263             [ fill-redirection ] keep
 264             dup call-CreateProcess
 265             lpProcessInformation>>
 266         ] with-destructors
 267     ] [ launch-error ] recover ;