[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

The following commit has been merged in the master branch:
commit 0c638a2db0812831233ffa56f8fd0f10bfb79e4d
Author: John Goerzen <jgoerzen at complete.org>
Date:   Wed Oct 27 07:48:35 2004 +0100

    Fixed bug in pipe (not closing write side in child)
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.5--patch-17)

diff --git a/ChangeLog b/ChangeLog
index 99bff87..17a5d54 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,21 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.5
 #
 
+2004-10-27 01:48:35 GMT	John Goerzen <jgoerzen at complete.org>	patch-17
+
+    Summary:
+      Fixed bug in pipe (not closing write side in child)
+    Revision:
+      missingh--head--0.5--patch-17
+
+
+    new files:
+     mailprint.hs
+
+    modified files:
+     ChangeLog libsrc/MissingH/Cmd.hs
+
+
 2004-10-26 21:39:48 GMT	John Goerzen <jgoerzen at complete.org>	patch-16
 
     Summary:
diff --git a/libsrc/MissingH/Cmd.hs b/libsrc/MissingH/Cmd.hs
index a254a2c..22a5286 100644
--- a/libsrc/MissingH/Cmd.hs
+++ b/libsrc/MissingH/Cmd.hs
@@ -108,7 +108,7 @@ pOpen pm fp args func =
                                         hClose h
                                         return $! x
                          pOpen3 Nothing (Just (snd pipepair)) Nothing fp args
-                                callfunc
+                                callfunc (closeFd (fst pipepair))
          WriteToPipe -> do 
                         let callfunc _ = do
                                        closeFd (fst pipepair)
@@ -117,7 +117,7 @@ pOpen pm fp args func =
                                        hClose h
                                        return $! x
                         pOpen3 (Just (fst pipepair)) Nothing Nothing fp args
-                               callfunc
+                               callfunc (closeFd (snd pipepair))
 
 {- | Runs a command, redirecting things to pipes. -}
 pOpen3 :: Maybe Fd                      -- ^ Send stdin to this fd
@@ -125,26 +125,31 @@ pOpen3 :: Maybe Fd                      -- ^ Send stdin to this fd
        -> Maybe Fd                      -- ^ Get stderr from this fd
        -> FilePath                      -- ^ Command to run
        -> [String]                      -- ^ Command args
-       -> (ProcessID -> IO a)           -- ^ Action to run
+       -> (ProcessID -> IO a)           -- ^ Action to run in parent
+       -> IO ()                         -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@)
        -> IO a
-pOpen3 pin pout perr fp args func = 
+pOpen3 pin pout perr fp args func childfunc = 
     let mayberedir Nothing _ = return ()
         mayberedir (Just fromfd) tofd = do
                                         dupTo fromfd tofd
+                                        closeFd fromfd
                                         return ()
         childstuff = do
                      mayberedir pin stdInput
                      mayberedir pout stdOutput
                      mayberedir perr stdError
+                     childfunc
                      debugM (logbase ++ ".pOpen3")
                             ("Running: " ++ fp ++ " " ++ (show args))
                      executeFile fp True args Nothing
+        realfunc p = do
+                     System.Posix.Signals.installHandler
+                           System.Posix.Signals.sigPIPE
+                           System.Posix.Signals.Ignore
+                           Nothing
+                     func p
         in
         do 
-        System.Posix.Signals.installHandler
-                      System.Posix.Signals.sigPIPE
-                      System.Posix.Signals.Ignore
-                      Nothing
         p <- try (forkProcess childstuff)
         pid <- case p of
                 Right x -> return x
diff --git a/mailprint.hs b/mailprint.hs
new file mode 100644
index 0000000..e213888
--- /dev/null
+++ b/mailprint.hs
@@ -0,0 +1,24 @@
+-- arch-tag: print and mail doc from stdin
+import MissingH.Email.Sendmail
+import MissingH.Str
+import MissingH.Cmd
+import MissingH.Logging.Logger
+import MissingH.Logging.Handler.Syslog
+import System.IO
+
+recipients = ["jgoerzen at excelhustler.com"]
+printer = "isdept"
+
+main = do
+       updateGlobalLogger "MissingH.Cmd.safeSystem" (setLevel DEBUG)
+       updateGlobalLogger "MissingH.Cmd.pOpen3" (setLevel DEBUG)
+       hdlr <- openlog "mailprint" [PID] USER DEBUG
+       updateGlobalLogger rootLoggerName (setHandlers [hdlr])
+       c <- getContents
+       let msg = "From: MFG/Pro System <root at excelhustler.com>\n" ++
+             "To: " ++ (join "," recipients) ++ "\n" ++
+             "Subject: MFG/Pro Printer Output\n\n" ++ c
+       --sendmail Nothing recipients msg
+       pOpen WriteToPipe "cat" []
+         (\h -> hPutStr h ("FOO: " ++ c ++ ", FOO\n"))
+

-- 
haskell-testpack