Update examples
This commit is contained in:
86
testsuite/dynload/io/TestIO.hs
Normal file
86
testsuite/dynload/io/TestIO.hs
Normal file
@ -0,0 +1,86 @@
|
||||
{-# OPTIONS -fglasgow-exts -cpp #-}
|
||||
--
|
||||
-- Copyright (c) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
|
||||
-- LGPL version 2.1 or later (see http://www.gnu.org/copyleft/lesser.html)
|
||||
--
|
||||
|
||||
module TestIO ( resource_dyn ) where
|
||||
|
||||
import API
|
||||
import AltData.Dynamic
|
||||
|
||||
import System.IO
|
||||
import System.Posix.Types ( ProcessID, Fd )
|
||||
import System.Posix.Process ( forkProcess, executeFile, getProcessID )
|
||||
import System.Posix.IO ( createPipe, stdInput,
|
||||
stdOutput, fdToHandle, closeFd, dupTo )
|
||||
|
||||
resource_dyn :: Dynamic
|
||||
resource_dyn = toDyn resource
|
||||
|
||||
resource :: TestIO
|
||||
resource = testio { field = date }
|
||||
|
||||
|
||||
--
|
||||
-- call a shell command , returning it's output
|
||||
--
|
||||
date :: IO String
|
||||
date = do (hdl,_,_) <- catch (popen "/bin/date") (\_->error "popen failed")
|
||||
hGetLine hdl
|
||||
|
||||
------------------------------------------------------------------------
|
||||
--
|
||||
-- my implementation of $val = `cmd`; (if this was perl)
|
||||
--
|
||||
-- provide similar functionality to popen(3),
|
||||
-- along with bidirectional ipc via pipes
|
||||
-- return's the pid of the child process
|
||||
--
|
||||
-- there are two different forkProcess functions. the pre-620 was a
|
||||
-- unix-fork style function, and the modern function has semantics more
|
||||
-- like the Awkward-Squad paper. We provide implementations of popen
|
||||
-- using both versions, depending on which GHC the user wants to try.
|
||||
--
|
||||
|
||||
popen :: FilePath -> IO (Handle, Handle, ProcessID)
|
||||
popen cmd = do
|
||||
(pr, pw) <- createPipe
|
||||
(cr, cw) <- createPipe
|
||||
|
||||
-- parent --
|
||||
let parent = do closeFd cw
|
||||
closeFd pr
|
||||
-- child --
|
||||
let child = do closeFd pw
|
||||
closeFd cr
|
||||
exec cmd (pr,cw)
|
||||
error "exec cmd failed!" -- typing only
|
||||
|
||||
-- if the parser front end understood cpp, this would work
|
||||
-- #if __GLASGOW_HASKELL__ >= 601
|
||||
pid <- forkProcess child -- fork child
|
||||
parent -- and run parent code
|
||||
-- #else
|
||||
-- p <- forkProcess
|
||||
-- pid <- case p of
|
||||
-- Just pid -> parent >> return pid
|
||||
-- Nothing -> child
|
||||
-- #endif
|
||||
|
||||
hcr <- fdToHandle cr
|
||||
hpw <- fdToHandle pw
|
||||
|
||||
return (hcr,hpw,pid)
|
||||
|
||||
--
|
||||
-- execve cmd in the child process, dup'ing the file descriptors passed
|
||||
-- as arguments to become the child's stdin and stdout.
|
||||
--
|
||||
exec :: FilePath -> (Fd,Fd) -> IO ()
|
||||
exec cmd (pr,cw) = do
|
||||
dupTo pr stdInput
|
||||
dupTo cw stdOutput
|
||||
executeFile cmd False [] Nothing
|
||||
|
||||
------------------------------------------------------------------------
|
Reference in New Issue
Block a user