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