Just to be sure, I've changed to example program a bit (see attachment). I think it now demonstrates clearly that there must be a bug in the libraries.
- If the child closes its child's stdin before calling executeFile, all data gets through. - If instead the child's child (echo.c) closes stdin immediately after being executed, some data is lost. Volker
#include <stdio.h>
main(int argc, char** argv)
{
close(0);
if (argc >= 2)
puts(argv[1]);
return 0;
}
0 :: parent child echo ./parent > /dev/null parent : parent.hs ghc -O -o parent parent.hs -package posix -package util -package std -syslib lang child : child.hs ghc -O -o child child.hs -package posix -package util -package std -syslib lang echo : echo.c gcc -o echo echo.c clean :: rm -f *.o *~ parent child echo *.hi
import System
import List
import Posix
import PosixUtil
import IO
main = do
pipeto senden "./child" []
hPutStrLn stderr ("sent: " ++ show (length senden))
senden = concat (take 200 (repeat "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx\n"))
pipeto :: String
-> String
-> [String]
-> IO ()
pipeto eing prog par = do
catch (do (zu, von) <- createPipe -- Pipe von -->
zu erzeugen
vonh <- fdToHandle von -- F�r von
brauchen wir einen Handle
hSetBuffering vonh NoBuffering -- nichts
zur�ckhalten, wenn der Kindproze� es lesen will
mpid <- forkProcess -- fork().
Danach hat die Pipe vier offene Enden.
case mpid of
Nothing -> do -- Kind
hClose vonh --
Kind-Schreibende schlie�en
dupTo zu (intToFd 0) -- Kind-Leseende
auf die Standardeingabe kopieren
fdClose zu -- erstes
Kind-Leseende schlie�en
executeFile' prog True par Nothing
Just pid -> do -- Vater
fdClose zu --
Vater-Leseende schlie�en
hPutStr vonh eing -- Text druch
die R�hre (verz�gert)
hClose vonh --
Vater-Schreibende schlie�en
(Just ps) <- getProcessStatus True True pid -- auf
angehaltenes Kind warten
if ps == Exited ExitSuccess
then return ()
else failIO ("Kommando fehlgeschlagen mit " ++ show ps ++ ":\n"
++ kommando prog par)
)
(\err -> do errno <- getErrorCode
hPutStrLn stderr ("Aufruf fehlgeschlagen: ... | " ++ kommando
prog par
++ "\nerrno = " ++ show errno)
ioError err)
executeFile' :: FilePath -- Command
-> Bool -- Search PATH?
-> [String] -- Arguments
-> Maybe [(String, String)] -- Environment
-> IO a
executeFile' cmd args env ca = do
executeFile cmd args env ca
hPutStrLn stderr ("Kommando " ++ cmd ++ " nicht gefunden")
exitFailure
failIO :: String -> IO a
failIO meld = do
hPutStrLn stderr meld
exitFailure
kommando :: String -> [String] -> String
kommando k par =
concat (intersperse " " (map shell_quote (k:par)))
shell_quote :: String -> String
shell_quote txt =
let need_to_quote c = c `elem` "' \t\n\"\\|&;()<>!{}*[?]^$`#"
quote (z:zs) =
if (z `elem` "\"$`\\") then ('\\':(z:(quote zs)))
else (z:(quote zs))
quote "" = "\""
in if any need_to_quote txt
then '"' : quote txt
else txt
import System
import List
import Posix
import PosixUtil
import IO
main = do
qinh <- getContents
let pfade = zeilen qinh
mapM_ (\pfad -> run "./echo" [pfad]) pfade
hPutStrLn stderr ("received: " ++ show (length qinh))
run :: FilePath -- Command
-> [String] -- Arguments
-> IO ()
run prog par =
callIO (\ps -> "Kommando fehlgeschlagen mit " ++ show ps ++ ":\n" ++ kommando prog
par)
(executeFile' prog True par Nothing)
-- instead, to avoid bug:
-- (hClose stdin >> executeFile' prog True par Nothing)
-- Die gegebene Aktion als neuen Proze� ausf�hren. Kind wegforken und auf
-- dessen Beendigung warten. Sein Ergebnis �berwachen und bei Fehler mit
-- Meldung abbrechen. Der erste Parameter ist eine Funktion, die aus einem
-- ExitStatus eine Fehlermeldung generiert. Sie wird nur mit (Exited
-- (ExitFailure _)) oder (Terminated _) aufgerufen.
callIO :: (ProcessStatus -> String) -- Fehlermeldung erzeugen
-> IO () -- Kindproze�
-> IO ()
callIO fm io = do
maybepid <- forkProcess
case maybepid of
Nothing -> -- Kind
io >> exitWith ExitSuccess
Just pid -> do -- Vater
(Just ps) <- getProcessStatus True True pid -- auf angehaltenes Kind
warten
if ps == Exited ExitSuccess
then return ()
else failIO (fm ps)
zeilen :: String -> [String]
zeilen txt =
let gruppen = groupBy (\a b -> (a == '\n') == (b == '\n')) txt
in filter (\str -> filter (/= '\n') str /= "") gruppen
kommando :: String -> [String] -> String
kommando k par =
concat (intersperse " " (map shell_quote (k:par)))
executeFile' :: FilePath -- Command
-> Bool -- Search PATH?
-> [String] -- Arguments
-> Maybe [(String, String)] -- Environment
-> IO a
executeFile' cmd args env ca = do
executeFile cmd args env ca
hPutStrLn stderr ("Kommando " ++ cmd ++ " nicht gefunden")
exitFailure
failIO :: String -> IO a
failIO meld = do
hPutStrLn stderr meld
exitFailure
shell_quote :: String -> String
shell_quote txt =
let need_to_quote c = c `elem` "' \t\n\"\\|&;()<>!{}*[?]^$`#"
quote (z:zs) =
if (z `elem` "\"$`\\") then ('\\':(z:(quote zs)))
else (z:(quote zs))
quote "" = "\""
in if any need_to_quote txt
then '"' : quote txt
else txt
signature.asc
Description: This is a digitally signed message part
