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