-- $Id: POpen.hs,v 1.4 2004/03/16 16:16:17 graham Exp $
--
--  popen-like library for Win32
--
--  Author : Graham Klyne
--
--  Copyright (c) 2004, G. Klyne
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Library General Public License for more details.
--
-- Description
--
--  Spawn a Win32 subprocess, connecting the standard I/O streams to
--  file descriptors in the calling program.
--
--  This code is based on the module Win32Spawn which is part of the
--  library code shipped with GHC, but it presents an interface
--  that is like the POpen module, also shipped with GHC.

module Win32.POpen (popen, popenEnvDir)
where

import CTypes
import Ptr
import CString
-- import GHC.Handle
-- import Handle
import System.Posix.Internals( FDType( RegularFile ) )
import Storable
import Word ( Word32 )
import MarshalUtils
import Monad ( when )
import Hugs.IO
import Hugs.Directory
import List( intersperse )
import Maybe( isJust, fromJust )

import TraceHelpers( trace )

foreign import ccall "spawnProc" spawnProc ::
    CString -> Ptr CInt -> Ptr CInt -> Ptr CInt -> IO CInt

-- Supply missing definitions from Posix
type ProcessID = Word32
--

-- This function is verbatim from Win32Spawn.hs:
spawn :: String
    -> IO ( Handle  -- write handle to child's stdin
          , Handle  -- read handle to child's stdout
          , Handle  -- read handle to child's stderr
          )
spawn cmd =
  withCString cmd $ \ p_cmd ->
   withObject 0 $ \ p_wIn  ->
    withObject 0 $ \ p_rOut ->
     withObject 0 $ \ p_rErr -> do
       rc  <- spawnProc p_cmd p_wIn p_rOut p_rErr
       when (rc /= 0) (ioError (userError ("runProc: unable to spawn " ++ show cmd)))
       wIn <- peek p_wIn
       trace ("wIn "++show wIn) $ return ()
{-  Hugs:
primitive openFd    :: Int    -- file descriptor
                    -> Bool   -- True => it's a socket.
                    -> IOMode -- what mode to open the handle in.
                    -> Bool   -- binary?
                    -> IO Handle
-}
       hIn <- openFd (fromIntegral wIn) False WriteMode False
       trace ("hIn "++show hIn) $ return ()

{- GHC:
       hIn <- openFd (fromIntegral wIn) (Just RegularFile)
             ("<fd " ++ show wIn ++ ">") WriteMode False False
-}
       hSetBuffering hIn NoBuffering
       rOut <- peek p_rOut
       trace ("rOut "++show rOut) $ return ()
       hOut <- openFd (fromIntegral rOut) False ReadMode True
       trace ("hOut "++show hOut) $ return ()
{- GHC:
       hOut <- openFd (fromIntegral rOut) (Just RegularFile)
              ("<fd " ++ show rOut ++ ">") ReadMode True False
-}
       hSetBuffering hOut NoBuffering
       rErr <- peek p_rErr
       trace ("rErr "++show rErr) $ return ()
       hErr <- openFd (fromIntegral rErr) False ReadMode True
       trace ("hErr "++show hErr) $ return ()
{- GHC:
       hErr <- openFd (fromIntegral rErr) (Just RegularFile)
              ("<fd " ++ show rErr ++ ">") ReadMode True False
-}
       hSetBuffering hErr NoBuffering
       return (hIn, hOut, hErr)


--  Function interfaces matching original POpen module
popen :: FilePath                       -- Command
      -> [String]                       -- Arguments
      -> Maybe String                   -- Input
      -> IO (String, String, ProcessID) -- (stdout, stderr, pid)
popen path args inpt =
    popenEnvDir path args inpt Nothing Nothing

-- This version ignores the supplied environment and directory
-- and returns a dummy ProcessID value
popenEnvDir :: FilePath                         -- Command
              -> [String]                       -- Arguments
              -> Maybe String                   -- Input
              -> Maybe [(String, String)]       -- Environment
              -> Maybe FilePath                 -- Working directory
                                                -- (stdin, stdout, stderr, pid)
              -> IO (String, String, ProcessID)
popenEnvDir path args inpt env dir =
    do  { let cmd = path++" "++concat (intersperse " " args)
        ; (hin, hout, herr) <- spawn cmd
        ; when (isJust inpt) (hPutStr hin $ fromJust inpt)
{-
            do  { hPutStr hin $ fromJust inpt
                -- I think this may be in danger of blocking/deadlocking
                -- The original POpen does this *before* starting the process
                -- so may be prone to the same problems.
                -- Or does lazy evaluation save the day here?
                }
-}
        ; hClose hin
        ; outstr <- hGetContents hout
        ; errstr <- hGetContents herr
        ; return (outstr, errstr, 42)
        -- When do handles hout and herr get closed?
        -- I think they can't be closed here because the
        -- string results are lazily evaluated
        }

-- This function from the old POpen module might be useful later?
maybeChangeWorkingDirectory :: Maybe FilePath -> IO ()
maybeChangeWorkingDirectory dir =
    case dir of
             Nothing -> return ()
             Just x  -> setCurrentDirectory x

--------------------------------------------------------------------------------
--
-- $Log: POpen.hs,v $
-- Revision 1.4  2004/03/16 16:16:17  graham
-- Add tracing to module POpen
--
-- Revision 1.3  2004/02/02 15:23:12  graham
-- Sync.
--
-- Revision 1.2  2004/01/26 17:56:42  graham
-- Successfully compiled revised POpen to a DLL
--
-- Revision 1.1  2004/01/22 18:26:05  graham
-- Save Win32.POpen files to CVS
--