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