basis/io/windows/nt/launcher/launcher.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 destructors io
   4 io.windows libc io.ports io.pipes windows.types
   5 math windows.kernel32 windows namespaces io.launcher kernel
   6 sequences windows.errors assocs splitting system strings
   7 io.windows.launcher io.windows.files
   8 io.backend io.files io.files.private combinators shuffle
   9 accessors locals ;
  10 IN: io.windows.nt.launcher
  11
  12 : duplicate-handle ( handle -- handle' )
  13     GetCurrentProcess ! source process
  14     swap ! handle
  15     GetCurrentProcess ! target process
  16     f <void*> [ ! target handle
  17         DUPLICATE_SAME_ACCESS ! desired access
  18         TRUE ! inherit handle
  19         DUPLICATE_CLOSE_SOURCE ! options
  20         DuplicateHandle win32-error=0/f
  21     ] keep *void* ;
  22
  23 ! /dev/null simulation
  24 : null-input ( -- pipe )
  25     (pipe) [ in>> handle>> ] [ out>> dispose ] bi ;
  26
  27 : null-output ( -- pipe )
  28     (pipe) [ in>> dispose ] [ out>> handle>> ] bi ;
  29
  30 : null-pipe ( mode -- pipe )
  31     {
  32         { GENERIC_READ [ null-input ] }
  33         { GENERIC_WRITE [ null-output ] }
  34     } case ;
  35
  36 ! The below code is based on the example given in
  37 ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
  38
  39 : redirect-default ( obj access-mode create-mode -- handle )
  40     3drop f ;
  41
  42 : redirect-closed ( obj access-mode create-mode -- handle )
  43     drop nip null-pipe ;
  44
  45 :: redirect-file ( path access-mode create-mode -- handle )
  46     path normalize-path
  47     access-mode
  48     share-mode
  49     default-security-attributes
  50     create-mode
  51     FILE_ATTRIBUTE_NORMAL ! flags and attributes
  52     f ! template file
  53     CreateFile dup invalid-handle? <win32-file> &dispose handle>> ;
  54
  55 : redirect-append ( path access-mode create-mode -- handle )
  56     >r >r path>> r> r>
  57     drop OPEN_ALWAYS
  58     redirect-file
  59     dup 0 FILE_END set-file-pointer ;
  60
  61 : redirect-handle ( handle access-mode create-mode -- handle )
  62     2drop handle>> duplicate-handle ;
  63
  64 : redirect-stream ( stream access-mode create-mode -- handle )
  65     >r >r underlying-handle handle>> r> r> redirect-handle ;
  66
  67 : redirect ( obj access-mode create-mode -- handle )
  68     {
  69         { [ pick not ] [ redirect-default ] }
  70         { [ pick +closed+ eq? ] [ redirect-closed ] }
  71         { [ pick string? ] [ redirect-file ] }
  72         { [ pick appender? ] [ redirect-append ] }
  73         { [ pick win32-file? ] [ redirect-handle ] }
  74         [ redirect-stream ]
  75     } cond
  76     dup [ dup t set-inherit ] when ;
  77
  78 : redirect-stdout ( process args -- handle )
  79     drop
  80     stdout>>
  81     GENERIC_WRITE
  82     CREATE_ALWAYS
  83     redirect
  84     STD_OUTPUT_HANDLE GetStdHandle or ;
  85
  86 : redirect-stderr ( process args -- handle )
  87     over stderr>> +stdout+ eq? [
  88         nip
  89         lpStartupInfo>> STARTUPINFO-hStdOutput
  90     ] [
  91         drop
  92         stderr>>
  93         GENERIC_WRITE
  94         CREATE_ALWAYS
  95         redirect
  96         STD_ERROR_HANDLE GetStdHandle or
  97     ] if ;
  98
  99 : redirect-stdin ( process args -- handle )
 100     drop
 101     stdin>>
 102     GENERIC_READ
 103     OPEN_EXISTING
 104     redirect
 105     STD_INPUT_HANDLE GetStdHandle or ;
 106
 107 M: winnt fill-redirection ( process args -- )
 108     [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
 109     [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
 110     [ 2dup redirect-stdin  ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
 111     2drop ;