[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 4f27f79a737d060bdf9671cd92f3b8f59023f001
Author: John Goerzen <jgoerzen at complete.org>
Date:   Wed Oct 27 02:43:33 2004 +0100

    Checkpointing
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.5--patch-12)

diff --git a/ChangeLog b/ChangeLog
index 6d683ac..6fa8603 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,19 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.5
 #
 
+2004-10-26 20:43:33 GMT	John Goerzen <jgoerzen at complete.org>	patch-12
+
+    Summary:
+      Checkpointing
+    Revision:
+      missingh--head--0.5--patch-12
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/Cmd.hs
+     libsrc/MissingH/Email/Sendmail.hs
+
+
 2004-10-26 20:28:43 GMT	John Goerzen <jgoerzen at complete.org>	patch-11
 
     Summary:
diff --git a/libsrc/MissingH/Cmd.hs b/libsrc/MissingH/Cmd.hs
index 38a17cf..9be6c15 100644
--- a/libsrc/MissingH/Cmd.hs
+++ b/libsrc/MissingH/Cmd.hs
@@ -75,14 +75,14 @@ safeSystem command args =
     ec <- rawSystem command args
     case ec of
             ExitSuccess -> return ()
-            ExitFailure fc -> cmdfailed command args fc
+            ExitFailure fc -> cmdfailed "safeSystem" command args fc
 
-cmdfailed :: FilePath -> [String] -> Int -> IO a
-cmdfailed command args failcode = do
+cmdfailed :: String -> FilePath -> [String] -> Int -> IO a
+cmdfailed funcname command args failcode = do
     let errormsg = "Command " ++ command ++ " " ++ (show args) ++
             " failed; exit code " ++ (show failcode)
     let e = userError (errormsg)
-    warningM (logbase ++ ".safeSystem") errormsg
+    warningM (logbase ++ "." ++ funcname) errormsg
     ioError e
 
 {- | Open a pipe to the specified command.
@@ -97,25 +97,28 @@ FIXME: this slowly leaks FDs!
 pOpen :: PipeMode -> FilePath -> [String] -> 
          (Handle -> IO a) -> IO a
 pOpen pm fp args func =
-    do
-    pipepair <- createPipe
-    fsth <- fdToHandle (fst pipepair)
-    sndh <- fdToHandle (snd pipepair)
-    case pm of
+    let realfunc h = do
+                     x <- func h
+                     hClose h
+                     return x
+        in
+        do
+        pipepair <- createPipe
+        fsth <- fdToHandle (fst pipepair)
+        sndh <- fdToHandle (snd pipepair)
+        case pm of
          ReadFromPipe -> do
                          let callfunc = do
                                         --hClose sndh
-                                        x <- func fsth
-                                        hClose fsth
-                                        return x
+                                        x <- realfunc fsth
+                                        return $! x
                          pOpen3 Nothing (Just (snd pipepair)) Nothing fp args
                                 callfunc
          WriteToPipe -> do 
                         let callfunc = do
                                        --hClose fsth
-                                       x <- func sndh
-                                       hClose sndh
-                                       return x
+                                       x <- realfunc sndh
+                                       return $! x
                         pOpen3 (Just (fst pipepair)) Nothing Nothing fp args
                                callfunc
 
@@ -144,11 +147,11 @@ pOpen3 pin pout perr fp args func =
         do 
         pid <- forkProcess childstuff
         retval <- func
-        seq retval (return ())
+        let rv = seq retval retval
         status <- getProcessStatus True False pid
         case status of
            Nothing -> fail "Got no process status back"
-           Just (Exited (ExitSuccess)) -> return retval
-           Just (Exited (ExitFailure fc)) -> cmdfailed fp args fc
+           Just (Exited (ExitSuccess)) -> return rv
+           Just (Exited (ExitFailure fc)) -> cmdfailed "pOpen3" fp args fc
            Just (Terminated sig) -> fail ("Command terminated by signal" ++ show sig)
            Just (Stopped sig) -> fail ("Command stopped by signal" ++ show sig)
diff --git a/libsrc/MissingH/Email/Sendmail.hs b/libsrc/MissingH/Email/Sendmail.hs
index 581f594..2ffe802 100644
--- a/libsrc/MissingH/Email/Sendmail.hs
+++ b/libsrc/MissingH/Email/Sendmail.hs
@@ -70,7 +70,13 @@ If @sendmail@ is on the @PATH@, it will be used; otherwise, a list of system
 default locations will be searched.
 
 A failure will be logged, since this function uses 'MissingH.Cmd.safeSystem'
-internally. -}
+internally.
+
+This function will first try @sendmail at .  If it does not exist, an error is
+logged under @MissingH.Cmd.pOpen3@ and various default @sendmail@ locations
+are tried.  If that still fails, an error is logged and an exception raised.
+
+ -}
 sendmail :: Maybe String                -- ^ The envelope from address.  If not specified, takes the system's default, which is usually based on the effective userid of the current process.  This is not necessarily what you want, so I recommend specifying it.
          -> [String]                    -- ^ A list of recipients for your message.  An empty list is an error.
          -> String                      -- ^ The message itself.
@@ -82,7 +88,7 @@ sendmail (Just from) recipients msg =
     
 sendmail_worker :: [String] -> String -> IO ()
 sendmail_worker args msg =
-    let func h = hPutStr h msg
+    let func h = hPutStr h msg 
         in
         do
         --pOpen WriteToPipe "/usr/sbin/sendmail" args func

-- 
haskell-testpack