[project @ 2005-05-06 00:30:56 by sof]

[mingw only]
Work around bug in win32 Console API which showed up in the GHCi UI:
if the user typed in characters prior to the appearance of the prompt,
the first of these characters always came out as a 'g'. The GHCi UI does
for good reasons one-character reads from 'stdin', which causes the
underlying APIs to become confused. A simple repro case is the following
piece of C code:

/*----------------------*/
#include <stdio.h>
#include <windows.h>
int main()
{
    char ch1,ch2;
    HANDLE hStdIn = GetStdHandle(STD_INPUT_HANDLE);
    DWORD dw;

    /* Type in some characters before the prompt appears and be amused.. */
    sleep(1000); printf("? ");
    ReadConsoleA(hStdIn,&ch1,1,&dw,NULL);
    ReadConsoleA(hStdIn,&ch2,1,&dw,NULL);
/*  or, if you want to use libc:
    read(0,&ch1,1); read(0,&ch2,1); */

    printf("%c%c\n", ch1,ch2);
    return 0;
}
/*----------------------*/

This happens across win32 OSes, and I can't see anything untoward as far
as API usage goes (the GHC IO implementation uses read(), but that
reduces to ReadConsoleA() calls.) People inside the Behemoth might want
to have a closer look at this..

Not much we can do about this except work around the problem by flushing
the input buffer prior to reading from stdin. Not ideal, as type-ahead
is a useful feature. Flushing is handled by GHC.ConsoleHandler.flushConsole

Merge to STABLE.

3 files changed, 27 insertions, 0 deletions

diff --git a/libraries/base/GHC/ConsoleHandler.hs b/libraries/base/GHC/ConsoleHandler.hs
index 77ea7b4400..d84f533080 100644
--- a/libraries/base/GHC/ConsoleHandler.hs
+++ b/libraries/base/GHC/ConsoleHandler.hs
@@ -21,6 +21,7 @@ import Prelude -- necessary to get dependencies right
 	( Handler(..)
 	, installHandler
 	, ConsoleEvent(..)
+	, flushConsole
 	) where
 
 {-
@@ -31,6 +32,8 @@ import Prelude -- necessary to get dependencies right
 
 import Foreign
 import Foreign.C
+import GHC.IOBase
+import GHC.Handle
 
 data Handler
  = Default
@@ -93,4 +96,14 @@ foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent"
   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
 foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
   rts_ConsoleHandlerDone :: CInt -> IO ()
+
+
+flushConsole :: Handle -> IO ()
+flushConsole h = 
+  wantReadableHandle "flushConsole" h $ \ h_ -> 
+     throwErrnoIfMinus1Retry_ "flushConsole"
+      (flush_console_fd (fromIntegral (haFD h_)))
+
+foreign import ccall unsafe "consUtils.h flush_input_console__"
+	flush_console_fd :: CInt -> IO CInt
 #endif /* mingw32_HOST_OS */
diff --git a/libraries/base/cbits/consUtils.c b/libraries/base/cbits/consUtils.c
index af29b599f4..bb9e154e86 100644
--- a/libraries/base/cbits/consUtils.c
+++ b/libraries/base/cbits/consUtils.c
@@ -64,4 +64,17 @@ get_console_echo__(int fd)
     return -1;
 }
 
+int
+flush_input_console__(int fd)
+{
+    HANDLE h;
+    if ( (h = (HANDLE)_get_osfhandle(fd)) != INVALID_HANDLE_VALUE ) {
+	if ( FlushConsoleInputBuffer(h) ) {
+	    return 0;
+	}
+    }
+    /* ToDo: translate GetLastError() into something errno-friendly */
+    return -1;
+}
+
 #endif /* defined(mingw32_HOST_OS) || ... */
diff --git a/libraries/base/include/consUtils.h b/libraries/base/include/consUtils.h
index e6a04e87dc..953f5c7289 100644
--- a/libraries/base/include/consUtils.h
+++ b/libraries/base/include/consUtils.h
@@ -8,4 +8,5 @@
 extern int set_console_buffering__(int fd, int cooked);
 extern int set_console_echo__(int fd, int on);
 extern int get_console_echo__(int fd);
+extern int flush_input_console__ (int fd);
 #endif