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 combinators.short-circuit
   5 concurrency.flags continuations debugger destructors init io
   6 io.backend io.backend.windows io.files io.files.private
   7 io.files.windows io.launcher io.launcher.private io.pathnames
   8 io.pipes io.pipes.windows io.ports kernel libc literals locals
   9 make math namespaces prettyprint sequences specialized-arrays
  10 splitting splitting.monotonic strings system threads windows
  11 windows.errors windows.handles windows.kernel32 windows.types
  12 windows.user32 ;
  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 group>> [
 112         {
 113             { +same-group+ [ ] }
 114             { +new-session+ [ DETACHED_PROCESS bitor CREATE_NEW_PROCESS_GROUP bitor ] }
 115             { +new-group+ [ DETACHED_PROCESS bitor CREATE_NEW_PROCESS_GROUP bitor ] }
 116             [ drop ]
 117         } case
 118     ] when*
 119     pick lookup-priority [ bitor ] when*
 120     >>dwCreateFlags ;
 121
 122 : fill-lpEnvironment ( process args -- process args )
 123     over pass-environment? [
 124         [
 125             over get-environment
 126             [ swap % "=" % % "\0" % ] assoc-each
 127             "\0" %
 128         ] ushort-array{ } make
 129         >>lpEnvironment
 130     ] when ;
 131
 132 : fill-startup-info ( process args -- process args )
 133     over hidden>> [ dup lpStartupInfo>> ] dip
 134     [
 135         flags{ STARTF_USESTDHANDLES STARTF_USESHOWWINDOW } >>dwFlags
 136         SW_HIDE >>wShowWindow
 137     ] [
 138         STARTF_USESTDHANDLES >>dwFlags
 139     ] if drop ;
 140
 141 : make-CreateProcess-args ( process -- args )
 142     default-CreateProcess-args
 143     fill-lpCommandLine
 144     fill-dwCreateFlags
 145     fill-lpEnvironment
 146     fill-startup-info
 147     nip ;
 148
 149 M: windows (current-process)
 150     GetCurrentProcessId ;
 151
 152 ERROR: launch-error process error ;
 153
 154 M: launch-error error.
 155     "Launching failed with error:" print
 156     dup error>> error. nl
 157     "Launch descriptor:" print nl
 158     process>> . ;
 159
 160 M: windows (kill-process)
 161     handle>> hProcess>> 255 TerminateProcess win32-error=0/f ;
 162
 163 : dispose-process ( process-information -- )
 164     ! From MSDN: "Handles in PROCESS_INFORMATION must be closed
 165     ! with CloseHandle when they are no longer needed."
 166     [ hProcess>> [ CloseHandle drop ] when* ]
 167     [ hThread>> [ CloseHandle drop ] when* ] bi ;
 168
 169 : exit-code ( process -- n )
 170     hProcess>>
 171     { DWORD } [ GetExitCodeProcess ] with-out-parameters
 172     swap win32-error=0/f ;
 173
 174 : process-exited ( process -- )
 175     dup handle>> exit-code
 176     over handle>> dispose-process
 177     notify-exit ;
 178
 179 M: windows (wait-for-processes)
 180     processes get keys dup
 181     [ handle>> hProcess>> ] void*-array{ } map-as
 182     [ length ] keep 0 0
 183     WaitForMultipleObjects
 184     dup 0xffffffff = [ win32-error ] when
 185     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
 186
 187 : duplicate-handle ( handle -- handle' )
 188     GetCurrentProcess ! source process
 189     swap handle>> ! handle
 190     GetCurrentProcess ! target process
 191     f void* <ref> [ ! target handle
 192         DUPLICATE_SAME_ACCESS ! desired access
 193         TRUE ! inherit handle
 194         0 ! options
 195         DuplicateHandle win32-error=0/f
 196     ] keep void* deref <win32-handle> &dispose ;
 197
 198 ! /dev/null simulation
 199 : null-input ( -- pipe )
 200     (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
 201
 202 : null-output ( -- pipe )
 203     (pipe) [ out>> &dispose ] [ in>> dispose ] bi ;
 204
 205 : null-pipe ( mode -- pipe )
 206     {
 207         { GENERIC_READ [ null-input ] }
 208         { GENERIC_WRITE [ null-output ] }
 209     } case ;
 210
 211 ! The below code is based on the example given in
 212 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
 213
 214 : redirect-default ( obj access-mode create-mode -- handle )
 215     3drop f ;
 216
 217 : redirect-closed ( obj access-mode create-mode -- handle )
 218     drop nip null-pipe ;
 219
 220 :: redirect-file ( path access-mode create-mode -- handle )
 221     path normalize-path
 222     access-mode
 223     share-mode
 224     default-security-attributes
 225     create-mode
 226     FILE_ATTRIBUTE_NORMAL ! flags and attributes
 227     f ! template file
 228     CreateFile check-invalid-handle <win32-file> &dispose ;
 229
 230 : redirect-append ( path access-mode create-mode -- handle )
 231     [ path>> ] 2dip
 232     drop OPEN_ALWAYS
 233     redirect-file
 234     dup 0 FILE_END set-file-pointer ;
 235
 236 : redirect-handle ( handle access-mode create-mode -- handle )
 237     2drop ;
 238
 239 : redirect-stream ( stream access-mode create-mode -- handle )
 240     [ underlying-handle ] 2dip redirect-handle ;
 241
 242 : redirect ( obj access-mode create-mode -- handle )
 243     {
 244         { [ pick not ] [ redirect-default ] }
 245         { [ pick +closed+ eq? ] [ redirect-closed ] }
 246         { [ pick string? ] [ redirect-file ] }
 247         { [ pick appender? ] [ redirect-append ] }
 248         { [ pick win32-file? ] [ redirect-handle ] }
 249         [ redirect-stream ]
 250     } cond
 251     dup [ dup t set-inherit handle>> ] when ;
 252
 253 : redirect-stdout ( process args -- handle )
 254     drop
 255     stdout>>
 256     GENERIC_WRITE
 257     CREATE_ALWAYS
 258     redirect
 259     STD_OUTPUT_HANDLE GetStdHandle or ;
 260
 261 : redirect-stderr ( process args -- handle )
 262     over stderr>> +stdout+ eq? [
 263         nip
 264         lpStartupInfo>> hStdOutput>>
 265     ] [
 266         drop
 267         stderr>>
 268         GENERIC_WRITE
 269         CREATE_ALWAYS
 270         redirect
 271         STD_ERROR_HANDLE GetStdHandle or
 272     ] if ;
 273
 274 : redirect-stdin ( process args -- handle )
 275     drop
 276     stdin>>
 277     GENERIC_READ
 278     OPEN_EXISTING
 279     redirect
 280     STD_INPUT_HANDLE GetStdHandle or ;
 281
 282 : fill-redirection ( process args -- )
 283     dup lpStartupInfo>>
 284     [ [ redirect-stdout ] dip hStdOutput<< ]
 285     [ [ redirect-stderr ] dip hStdError<< ]
 286     [ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
 287
 288 M: windows (run-process)
 289     [
 290         [
 291             dup make-CreateProcess-args
 292             current-directory get absolute-path >>lpCurrentDirectory
 293             [ fill-redirection ] keep
 294             dup call-CreateProcess
 295             lpProcessInformation>>
 296         ] with-destructors
 297     ] [ launch-error ] recover ;