Added getPid
authorTilman Blumhagen <tilman.blumhagen@googlemail.com>
Tue, 14 Nov 2017 16:45:57 +0000 (17:45 +0100)
committerTilman Blumhagen <tilman.blumhagen@googlemail.com>
Thu, 16 Nov 2017 17:01:53 +0000 (18:01 +0100)
System/Process.hs
changelog.md
test/main.hs

index a8e627a..2678a93 100644 (file)
@@ -46,6 +46,8 @@ module System.Process (
 
     -- ** Related utilities
     showCommandForUser,
+    Pid,
+    getPid,
 
     -- ** Control-C handling on Unix
     -- $ctlc-handling
@@ -87,13 +89,25 @@ import System.Exit      ( ExitCode(..) )
 import System.IO
 import System.IO.Error (mkIOError, ioeSetErrorString)
 
--- Provide the data constructors for CPid on GHC 7.4 and later
-#if !defined(WINDOWS) && MIN_VERSION_base(4,5,0)
+#if defined(WINDOWS)
+import System.Win32.Process (getProcessId, ProcessId)
+#else
 import System.Posix.Types (CPid (..))
 #endif
 
 import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) )
 
+-- | The platform specific type for a process identifier.
+--
+-- This is always an integral type. Width and signedness are platform specific.
+--
+-- @since 1.6.3.0
+#if defined(WINDOWS)
+type Pid = ProcessId
+#else
+type Pid = CPid
+#endif
+
 -- ----------------------------------------------------------------------------
 -- createProcess
 
@@ -563,6 +577,31 @@ showCommandForUser cmd args = unwords (map translate (cmd : args))
 
 
 -- ----------------------------------------------------------------------------
+-- getPid
+
+-- | Returns the PID (process ID) of a subprocess.
+--
+-- 'Nothing' is returned if the handle was already closed. Otherwise a
+-- PID is returned that remains valid as long as the handle is open.
+-- The operating system may reuse the PID as soon as the last handle to
+-- the process is closed.
+--
+-- @since 1.6.3.0
+getPid :: ProcessHandle -> IO (Maybe Pid)
+getPid (ProcessHandle mh _ _) = do
+  p_ <- readMVar mh
+  case p_ of
+#ifdef WINDOWS
+    OpenHandle h -> do
+      pid <- getProcessId h
+      return $ Just pid
+#else
+    OpenHandle pid -> return $ Just pid
+#endif
+    _ -> return Nothing
+
+
+-- ----------------------------------------------------------------------------
 -- waitForProcess
 
 {- | Waits for the specified process to terminate, and returns its exit code.
index c0441b2..9c37fc8 100644 (file)
@@ -2,6 +2,11 @@
 
 ## Unreleased changes
 
+## 1.6.3.0 *November 2017*
+
+* Added `getPid` and export of platform specific `Pid` type
+  [#109](https://github.com/haskell/process/pull/109)
+
 ## 1.6.2.0 *October 2017*
 
 * Allow async exceptions to be delivered to masked thread calling `waitForProcess`
index e088663..18fb3f6 100644 (file)
@@ -5,9 +5,10 @@ import System.IO.Error
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
 import System.Process
 import Control.Concurrent
+import Data.Char (isDigit)
 import Data.List (isInfixOf)
 import Data.Maybe (isNothing)
-import System.IO (hClose, openBinaryTempFile)
+import System.IO (hClose, openBinaryTempFile, hGetContents)
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
 import System.Directory (getTemporaryDirectory, removeFile)
@@ -94,6 +95,18 @@ main = do
         Nothing -> return ()
         Just ec -> error $ "waitForProcess not interrupted: sleep exited with " ++ show ec
 
+    putStrLn "testing getPid"
+    do
+      (_, Just out, _, p) <- createProcess $ (proc "sh" ["-c", "echo $$"]) {std_out = CreatePipe}
+      pid <- getPid p
+      line <- hGetContents out
+      putStrLn $ " queried PID: " ++ show pid
+      putStrLn $ " PID reported by stdout: " ++ show line
+      _ <- waitForProcess p
+      hClose out
+      let numStdoutPid = read (takeWhile isDigit line) :: Pid
+      unless (Just numStdoutPid == pid) $ error "subprocess reported unexpected PID"
+
     putStrLn "Tests passed successfully"
 
 withCurrentDirectory :: FilePath -> IO a -> IO a