On Mon, 11 Mar 2002, Simon Marlow wrote:
> > There seems to be a bug in the IO libraries. I'm using the following
> > procedure to call an external program and send it data through a pipe.
>
> Could you send us a complete example that we can run to reproduce the
> problem?
I've stripped down my program to produce an example. In the process, the
problem disappeard a few times. I hope it shows up on your machine. The
attached files reproduce it on my machine, but the exact results vary
from run to run.
Volker
import System
import List
import Posix
import PosixUtil
import IO
main = do
qinh <- getContents
let pfade = zeilen qinh
mapM_ (\pfad -> run "/bin/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)
-- 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
0 :: parent child
./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
clean ::
rm -f *.o *~ parent child *.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
