basis/io/launcher/windows/windows.factor

   1 ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.c-types arrays continuations io
   4 io.backend.windows io.pipes.windows.nt io.pathnames libc
   5 io.ports windows.types math windows.kernel32 namespaces make
   6 io.launcher kernel sequences windows.errors splitting system
   7 threads init strings combinators io.backend accessors
   8 concurrency.flags io.files assocs io.files.private windows
   9 destructors classes classes.struct specialized-arrays ;
  10 SPECIALIZED-ARRAY: ushort
  11 SPECIALIZED-ARRAY: void*
  12 IN: io.launcher.windows
  13
  14 TUPLE: CreateProcess-args
  15        lpApplicationName
  16        lpCommandLine
  17        lpProcessAttributes
  18        lpThreadAttributes
  19        bInheritHandles
  20        dwCreateFlags
  21        lpEnvironment
  22        lpCurrentDirectory
  23        lpStartupInfo
  24        lpProcessInformation ;
  25
  26 : default-CreateProcess-args ( -- obj )
  27     CreateProcess-args new
  28         STARTUPINFO <struct>
  29         dup class heap-size >>cb
  30     >>lpStartupInfo
  31     PROCESS_INFORMATION <struct> >>lpProcessInformation
  32     TRUE >>bInheritHandles
  33     0 >>dwCreateFlags ;
  34
  35 : call-CreateProcess ( CreateProcess-args -- )
  36     {
  37         [ lpApplicationName>> ]
  38         [ lpCommandLine>> ]
  39         [ lpProcessAttributes>> ]
  40         [ lpThreadAttributes>> ]
  41         [ bInheritHandles>> ]
  42         [ dwCreateFlags>> ]
  43         [ lpEnvironment>> ]
  44         [ lpCurrentDirectory>> ]
  45         [ lpStartupInfo>> ]
  46         [ lpProcessInformation>> ]
  47     } cleave
  48     CreateProcess win32-error=0/f ;
  49
  50 : count-trailing-backslashes ( str n -- str n )
  51     [ "\\" ?tail ] dip swap [
  52         1 + count-trailing-backslashes
  53     ] when ;
  54
  55 : fix-trailing-backslashes ( str -- str' )
  56     0 count-trailing-backslashes
  57     2 * CHAR: \\ <repetition> append ;
  58
  59 : escape-argument ( str -- newstr )
  60     CHAR: \s over member? [
  61         fix-trailing-backslashes "\"" dup surround
  62     ] when ;
  63
  64 : join-arguments ( args -- cmd-line )
  65     [ escape-argument ] map " " join ;
  66
  67 : lookup-priority ( process -- n )
  68     priority>> {
  69         { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
  70         { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
  71         { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
  72         { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
  73         { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
  74         { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
  75         [ drop f ]
  76     } case ;
  77
  78 : app-name/cmd-line ( process -- app-name cmd-line )
  79     command>> dup string? [
  80         " " split1
  81     ] [
  82         unclip swap join-arguments
  83     ] if ;
  84
  85 : cmd-line ( process -- cmd-line )
  86     command>> dup string? [ join-arguments ] unless ;
  87
  88 : fill-lpApplicationName ( process args -- process args )
  89     over app-name/cmd-line
  90     [ >>lpApplicationName ] [ >>lpCommandLine ] bi* ;
  91
  92 : fill-lpCommandLine ( process args -- process args )
  93     over cmd-line >>lpCommandLine ;
  94
  95 : fill-dwCreateFlags ( process args -- process args )
  96     0
  97     pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
  98     pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
  99     pick lookup-priority [ bitor ] when*
 100     >>dwCreateFlags ;
 101
 102 : fill-lpEnvironment ( process args -- process args )
 103     over pass-environment? [
 104         [
 105             over get-environment
 106             [ swap % "=" % % "\0" % ] assoc-each
 107             "\0" %
 108         ] ushort-array{ } make
 109         >>lpEnvironment
 110     ] when ;
 111
 112 : fill-startup-info ( process args -- process args )
 113     dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ;
 114
 115 HOOK: fill-redirection io-backend ( process args -- )
 116
 117 M: wince fill-redirection 2drop ;
 118
 119 : make-CreateProcess-args ( process -- args )
 120     default-CreateProcess-args
 121     os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
 122     fill-dwCreateFlags
 123     fill-lpEnvironment
 124     fill-startup-info
 125     nip ;
 126
 127 M: windows current-process-handle ( -- handle )
 128     GetCurrentProcessId ;
 129
 130 M: windows run-process* ( process -- handle )
 131     [
 132         current-directory get absolute-path cd
 133
 134         dup make-CreateProcess-args
 135         [ fill-redirection ] keep
 136         dup call-CreateProcess
 137         lpProcessInformation>>
 138     ] with-destructors ;
 139
 140 M: windows kill-process* ( handle -- )
 141     hProcess>> 255 TerminateProcess win32-error=0/f ;
 142
 143 : dispose-process ( process-information -- )
 144     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
 145     #! with CloseHandle when they are no longer needed."
 146     [ hProcess>> [ CloseHandle drop ] when* ]
 147     [ hThread>> [ CloseHandle drop ] when* ] bi ;
 148
 149 : exit-code ( process -- n )
 150     hProcess>>
 151     0 <ulong> [ GetExitCodeProcess ] keep *ulong
 152     swap win32-error=0/f ;
 153
 154 : process-exited ( process -- )
 155     dup handle>> exit-code
 156     over handle>> dispose-process
 157     notify-exit ;
 158
 159 M: windows wait-for-processes ( -- ? )
 160     processes get keys dup
 161     [ handle>> hProcess>> ] void*-array{ } map-as
 162     [ length ] keep 0 0
 163     WaitForMultipleObjects
 164     dup HEX: ffffffff = [ win32-error ] when
 165     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;