[commit: packages/Win32] Mistuke-fix-build, depend-os-windows, fix-appveyor-curl-ussue, master, win32-2.5.4.1-ghc-8.2: Add withHandleToHANDLE from ansi-terminal (#70) (729f902)
git at git.haskell.org
git at git.haskell.org
Mon Apr 17 21:28:18 UTC 2017
Repository : ssh://git@git.haskell.org/Win32
On branches: Mistuke-fix-build,depend-os-windows,fix-appveyor-curl-ussue,master,win32-2.5.4.1-ghc-8.2
Link : http://git.haskell.org/packages/Win32.git/commitdiff/729f9029e7a1fb8274c0b7f8065dec45f003405a
>---------------------------------------------------------------
commit 729f9029e7a1fb8274c0b7f8065dec45f003405a
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date: Thu Jan 12 11:26:38 2017 -0500
Add withHandleToHANDLE from ansi-terminal (#70)
* Add withHandleToHANDLE from ansi-terminal
Fixes #51.
* Add hANDLEToHandle
>---------------------------------------------------------------
729f9029e7a1fb8274c0b7f8065dec45f003405a
System/Win32/Types.hsc | 68 +++++++++++++++++++++++++++++++++++++++++--
changelog.md | 4 +++
tests/HandleConversion.hs | 16 ++++++++++
tests/HandleConversion.stdout | 3 ++
tests/all.T | 1 +
5 files changed, 89 insertions(+), 3 deletions(-)
diff --git a/System/Win32/Types.hsc b/System/Win32/Types.hsc
index f13f033..afefb50 100755
--- a/System/Win32/Types.hsc
+++ b/System/Win32/Types.hsc
@@ -21,20 +21,27 @@ module System.Win32.Types
, nullPtr
) where
-import Control.Exception (throwIO)
+import Control.Concurrent.MVar (readMVar)
+import Control.Exception (bracket, throwIO)
import Data.Bits (shiftL, shiftR, (.|.), (.&.))
import Data.Char (isSpace)
import Data.Int (Int32, Int64, Int16)
import Data.Maybe (fromMaybe)
+import Data.Typeable (cast)
import Data.Word (Word8, Word16, Word32, Word64)
import Foreign.C.Error (Errno(..), errnoToIOError)
import Foreign.C.String (newCWString, withCWStringLen)
import Foreign.C.String (peekCWString, peekCWStringLen, withCWString)
-import Foreign.C.Types (CChar, CUChar, CWchar, CInt(..), CIntPtr, CUIntPtr)
+import Foreign.C.Types (CChar, CUChar, CWchar, CInt(..), CIntPtr(..), CUIntPtr)
import Foreign.ForeignPtr (ForeignPtr, newForeignPtr, newForeignPtr_)
-import Foreign.Ptr (FunPtr, Ptr, nullPtr)
+import Foreign.Ptr (FunPtr, Ptr, nullPtr, ptrToIntPtr)
+import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr)
import Foreign (allocaArray)
+import GHC.IO.FD (FD(..))
+import GHC.IO.Handle.FD (fdToHandle)
+import GHC.IO.Handle.Types (Handle(..), Handle__(..))
import Numeric (showHex)
+import qualified System.IO as IO ()
import System.IO.Error (ioeSetErrorString)
import System.IO.Unsafe (unsafePerformIO)
@@ -51,6 +58,7 @@ finiteBitSize :: (Bits a) => a -> Int
finiteBitSize = bitSize
#endif
+#include <fcntl.h>
#include <windows.h>
##include "windows_cconv.h"
@@ -213,6 +221,60 @@ nullFinalHANDLE = unsafePerformIO (newForeignPtr_ nullPtr)
iNVALID_HANDLE_VALUE :: HANDLE
iNVALID_HANDLE_VALUE = castUINTPtrToPtr (-1)
+foreign import ccall "_open_osfhandle"
+ _open_osfhandle :: CIntPtr -> CInt -> IO CInt
+
+-- | Create a Haskell 'Handle' from a Windows 'HANDLE'.
+--
+-- Beware that this function allocates a new file descriptor. A consequence of
+-- this is that calling 'hANDLEToHandle' on the standard Windows handles will
+-- not give you 'IO.stdin', 'IO.stdout', or 'IO.stderr'. For example, if you
+-- run this code:
+--
+-- @
+-- import Graphics.Win32.Misc
+-- stdoutHANDLE <- getStdHandle sTD_OUTPUT_HANDLE
+-- stdout2 <- 'hANDLEToHandle' stdoutHANDLE
+-- @
+--
+-- Then although you can use @stdout2@ to write to standard output, it is not
+-- the case that @'IO.stdout' == stdout2 at .
+hANDLEToHandle :: HANDLE -> IO Handle
+hANDLEToHandle handle =
+ _open_osfhandle (fromIntegral (ptrToIntPtr handle)) (#const _O_BINARY) >>= fdToHandle
+
+foreign import ccall unsafe "_get_osfhandle"
+ c_get_osfhandle :: CInt -> IO HANDLE
+
+-- | Extract a Windows 'HANDLE' from a Haskell 'Handle' and perform
+-- an action on it.
+
+-- Originally authored by Max Bolingbroke in the ansi-terminal library
+withHandleToHANDLE :: Handle -> (HANDLE -> IO a) -> IO a
+withHandleToHANDLE haskell_handle action =
+ -- Create a stable pointer to the Handle. This prevents the garbage collector
+ -- getting to it while we are doing horrible manipulations with it, and hence
+ -- stops it being finalized (and closed).
+ withStablePtr haskell_handle $ const $ do
+ -- Grab the write handle variable from the Handle
+ let write_handle_mvar = case haskell_handle of
+ FileHandle _ handle_mvar -> handle_mvar
+ DuplexHandle _ _ handle_mvar -> handle_mvar
+ -- This is "write" MVar, we could also take the "read" one
+
+ -- Get the FD from the algebraic data type
+ Just fd <- fmap (\(Handle__ { haDevice = dev }) -> fmap fdFD (cast dev))
+ $ readMVar write_handle_mvar
+
+ -- Finally, turn that (C-land) FD into a HANDLE using msvcrt
+ windows_handle <- c_get_osfhandle fd
+
+ -- Do what the user originally wanted
+ action windows_handle
+
+withStablePtr :: a -> (StablePtr a -> IO b) -> IO b
+withStablePtr value = bracket (newStablePtr value) freeStablePtr
+
----------------------------------------------------------------
-- Errors
----------------------------------------------------------------
diff --git a/changelog.md b/changelog.md
index 0c94c59..6f86b44 100644
--- a/changelog.md
+++ b/changelog.md
@@ -1,5 +1,9 @@
# Changelog for [`Win32` package](http://hackage.haskell.org/package/Win32)
+## Unreleased GIT version
+
+* Add `withHandleToHANDLE` (originally found in the `ansi-terminal` library)
+
## 2.5.0.0 *Jan 2017*
* `failWith` (and the API calls that use it) now throw `IOError`s with proper
diff --git a/tests/HandleConversion.hs b/tests/HandleConversion.hs
new file mode 100644
index 0000000..55483fe
--- /dev/null
+++ b/tests/HandleConversion.hs
@@ -0,0 +1,16 @@
+module Main where
+
+import Graphics.Win32.Misc
+import System.IO
+import System.Win32.Types
+
+testStdHandle :: Handle -> StdHandleId -> IO ()
+testStdHandle haskHandle winStdHandle = do
+ winHandle <- getStdHandle winStdHandle
+ withHandleToHANDLE haskHandle $ print . (== winHandle)
+
+main :: IO ()
+main = do
+ testStdHandle stdin sTD_INPUT_HANDLE
+ testStdHandle stdout sTD_OUTPUT_HANDLE
+ testStdHandle stderr sTD_ERROR_HANDLE
diff --git a/tests/HandleConversion.stdout b/tests/HandleConversion.stdout
new file mode 100644
index 0000000..b8ca7e7
--- /dev/null
+++ b/tests/HandleConversion.stdout
@@ -0,0 +1,3 @@
+True
+True
+True
diff --git a/tests/all.T b/tests/all.T
index e541f3c..93531ae 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -7,3 +7,4 @@ test('helloworld', skip, compile_and_run, ['-package lang -package win32'])
test('lasterror', normal, compile_and_run, ['-package Win32'])
test('T4452', normal, compile_and_run, ['-package Win32'])
test('PokeTZI', normal, compile_and_run, ['-package Win32'])
+test('HandleConversion', normal, compile_and_run, ['-package Win32'])
More information about the ghc-commits
mailing list