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