basis/io/launcher/windows/nt/nt.factor

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