MODULE InterceptorStuff
  
  USE :: IFWINTY, ONLY: HANDLE
  IMPLICIT NONE
  PRIVATE
  
  PUBLIC :: WriteThreadEntry
  
  ! Our console handle (original stdout).
  INTEGER(HANDLE), PUBLIC :: console_handle
  ! Pipe read handle (attached to new stdout).
  INTEGER(HANDLE), PUBLIC :: read_handle
  
CONTAINS
  
  FUNCTION WriteThreadEntry(lpParameter) RESULT(rc)
    
    USE IFWINTY
    USE IFWIN
    
    !---------------------------------------------------------------------------
    ! Characteristics
    
    !DEC$ ATTRIBUTES STDCALL :: WriteThreadEntry
    INTEGER(LPVOID), INTENT(IN) :: lpParameter
    
    ! Function result
    INTEGER(DWORD) :: rc
    
    !---------------------------------------------------------------------------
    ! Local variables
    
    ! Win32 API result codes.
    INTEGER(BOOL) :: bool_result
    
    ! Number of bytes read from the pipe.
    INTEGER(DWORD) :: bytes_read
    ! Buffer for reading from the pipe.
    CHARACTER(100) :: buffer
    ! Number of characters written to console.
    INTEGER(DWORD) :: chars_written
    ! Attribute to write to console.
    INTEGER(WORD) :: attr
    
    ! Coords for where character will go.
    TYPE(T_COORD) :: coords
    
    ! Screen buffer info (we want the visible window size).
    TYPE(T_CONSOLE_SCREEN_BUFFER_INFO) :: buffer_info
    
    LOGICAL :: sin_cos        ! .FALSE - sin, .TRUE. cos.
    INTEGER :: ic             ! Character index.
    INTEGER :: pos            ! Current position.
    REAL :: arg               ! Argument to sin or cos.
    
    !***************************************************************************
    
    ! Find out how big our buffer is.
    bool_result = GetConsoleScreenBufferInfo(console_handle, buffer_info)
    
    ! Start at the left.
    pos = 0
    
    ! Start with sin curve
    sin_cos = .FALSE.
    
    ! Output colour.
    attr = IOR(FOREGROUND_RED, BACKGROUND_BLUE)
    
    ! Loop until no-one's talking to us.
    DO
      ! Get some text.
      bool_result = ReadFile( read_handle, LOC(buffer), LEN(buffer),  &
          LOC(bytes_read), NULL )
      ! zero (FALSE) probably indicates the pipe being closed.
      IF (bool_result == FALSE) EXIT
      
      ! Interpret the text.
      DO ic = 1, bytes_read
        IF (buffer(ic:ic) == ACHAR(13)) THEN        ! carriage return.
          pos = 0
        ELSE IF (buffer(ic:ic) == ACHAR(10)) THEN   ! line feed.
          sin_cos = .NOT. sin_cos
        ELSE                                        ! something to "print".
          ! Work out where to print it.
          coords%x = buffer_info%srWindow%Left + pos
          arg = pos / REAL( buffer_info%srWindow%Right  &
                - buffer_info%srWindow%Left ) * 2.0 * 3.14159
          IF (sin_cos) THEN
            arg = COS(arg)
          ELSE
            arg = SIN(arg)
          END IF
          coords%y = INT( (-arg / 2.0 + 0.5) &
              * (buffer_info%srWindow%Bottom - buffer_info%srWindow%Top) )  &
              + buffer_info%srWindow%Top
          
          ! Print it, with pretty colours.
          bool_result = WriteConsoleOutputCharacter( console_handle,  &
              buffer(ic:ic), 1, coords, LOC(chars_written) )
          bool_result = WriteConsoleOutputAttribute( console_handle,  &
              LOC(attr), 1, coords, LOC(chars_written) )
          
          ! Advance our pseudo cursor.
          pos = pos + 1
          ! if we made it to the right hand edge, then newline.
          IF ( pos > ( buffer_info%srWindow%Right - &
               buffer_info%srWindow%Left ) ) THEN
            pos = 0
            sin_cos = .NOT. sin_cos
          END IF
        END IF
      END DO
    END DO
    
    rc = lpParameter  ! Avoid not used.
    
  END FUNCTION WriteThreadEntry
  
END MODULE InterceptorStuff


PROGRAM ConsoleInterceptor
  
  USE IFWIN
  
  USE InterceptorStuff
  IMPLICIT NONE
  
  !-----------------------------------------------------------------------------
  
  ! Win32 API result codes.
  INTEGER(BOOL) :: bool_result
  INTEGER(DWORD) :: dword_result
  
  INTEGER(HANDLE) :: old_write_handle
  INTEGER(HANDLE) :: write_handle
  
  INTEGER(HANDLE) :: thread_handle
  INTEGER(DWORD) :: thread_id
  
  CHARACTER(:), ALLOCATABLE :: msg
  
  !*****************************************************************************
  
  ! Create a pipe, cannot be inherited, default buffer size
  bool_result = CreatePipe(read_handle, write_handle, NULL, 0_DWORD)
  IF (bool_result == 0_BOOL) STOP 'CreatePipe bombed!'
  
  ! Make this process' standard output the relevant pipe handle, saving the 
  ! old handle in the process.
  old_write_handle = GetStdHandle(-11_DWORD)
  IF (old_write_handle == 0_HANDLE) STOP 'GetStdHandle wouldn''t!'
  console_handle = old_write_handle
  
  bool_result = SetStdHandle(-11_DWORD, write_handle)
  IF (bool_result == 0_BOOL) STOP 'SetStdHandle didn''t!'
  
  ! From this point on the STOP messages are a little pointless, as 
  ! its likely the runtime can't write anything anyway.
  DO  ! pretending to be a BLOCK...
    thread_handle = CreateThread( 0_HANDLE, 0_HANDLE,  &
          LOC(WriteThreadEntry), 0_LPVOID, 0_DWORD, LOC(thread_id) )
    IF (thread_handle == 0_HANDLE) THEN
      msg = 'CreateThread got tangled!'
      EXIT
    END IF
    
    ! Write something.
    PRINT *, 'Hello world!'
    PRINT *, 'Another string that is a bit longer so that we can really test &
        &the shape of the output.'
    
    ! Set standard output back the way we found it.
    bool_result = SetStdHandle(-11_DWORD, old_write_handle)
    IF (bool_result == 0_BOOL) STOP 'SetStdHandle (the second time) failed!'
    
    ! Tell the thread we are done.
    bool_result = CloseHandle(write_handle)
    IF (bool_result == 0_BOOL) THEN
      msg = 'CloseHandle(write) came unstuck!'
      EXIT
    END IF
    
    ! Wait for the thread to finish.
    dword_result = WaitForSingleObject(thread_handle, INFINITE)
    IF (dword_result /= 0_DWORD) THEN
      msg = 'WaitForSingleObject was impatient!'
      EXIT
    END IF
    
    EXIT
  END DO
  
  IF (ALLOCATED(msg)) THEN
    PRINT *, msg
    STOP
  END IF
  
  ! Clean up our handles to date.
  bool_result = CloseHandle(thread_handle)
  bool_result = CloseHandle(read_handle)
  
  PRINT *, 'All done!'
  
END PROGRAM ConsoleInterceptor
