view release on metacpan or  search on metacpan

hugs98-Nov2003/fptools/libraries/base/System/Posix/Internals.hs  view on Meta::CPAN

    c_lflag <- c_lflag p_tios :: IO CTcflag
    let new_c_lflag
	 | on        = c_lflag .|. fromIntegral const_echo
	 | otherwise = c_lflag .&. complement (fromIntegral const_echo)
    poke_c_lflag p_tios (new_c_lflag :: CTcflag)

getEcho :: Int -> IO Bool
getEcho fd = do
  tcSetAttr fd $ \ p_tios -> do
    c_lflag <- c_lflag p_tios :: IO CTcflag
    return ((c_lflag .&. fromIntegral const_echo) /= 0)

setCooked :: Int -> Bool -> IO ()
setCooked fd cooked = 
  tcSetAttr fd $ \ p_tios -> do

    -- turn on/off ICANON
    c_lflag <- c_lflag p_tios :: IO CTcflag
    let new_c_lflag | cooked    = c_lflag .|. (fromIntegral const_icanon)
	            | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
    poke_c_lflag p_tios (new_c_lflag :: CTcflag)

    -- set VMIN & VTIME to 1/0 respectively
    when (not cooked) $ do
            c_cc <- ptr_c_cc p_tios
	    let vmin  = (c_cc `plusPtr` (fromIntegral const_vmin))  :: Ptr Word8
		vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8
	    poke vmin  1
	    poke vtime 0

tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a
tcSetAttr fd fun = do
     allocaBytes sizeof_termios  $ \p_tios -> do
	throwErrnoIfMinus1Retry "tcSetAttr"
	   (c_tcgetattr (fromIntegral fd) p_tios)

#ifdef __GLASGOW_HASKELL__
	-- Save a copy of termios, if this is a standard file descriptor.
	-- These terminal settings are restored in hs_exit().
	when (fd <= 2) $ do
	  p <- get_saved_termios fd
	  when (p == nullPtr) $ do
	     saved_tios <- mallocBytes sizeof_termios
	     copyBytes saved_tios p_tios sizeof_termios
	     set_saved_termios fd saved_tios
#endif

	-- tcsetattr() when invoked by a background process causes the process
	-- to be sent SIGTTOU regardless of whether the process has TOSTOP set
	-- in its terminal flags (try it...).  This function provides a
	-- wrapper which temporarily blocks SIGTTOU around the call, making it
	-- transparent.
	allocaBytes sizeof_sigset_t $ \ p_sigset -> do
	allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
	     c_sigemptyset p_sigset
	     c_sigaddset   p_sigset const_sigttou
	     c_sigprocmask const_sig_block p_sigset p_old_sigset
	     r <- fun p_tios  -- do the business
	     throwErrnoIfMinus1Retry_ "tcSetAttr" $
		 c_tcsetattr (fromIntegral fd) const_tcsanow p_tios
	     c_sigprocmask const_sig_setmask p_old_sigset nullPtr
	     return r

#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"
   get_saved_termios :: Int -> IO (Ptr CTermios)

foreign import ccall unsafe "HsBase.h __hscore_set_saved_termios"
   set_saved_termios :: Int -> (Ptr CTermios) -> IO ()
#endif

#else

-- 'raw' mode for Win32 means turn off 'line input' (=> buffering and
-- character translation for the console.) The Win32 API for doing
-- this is GetConsoleMode(), which also requires echoing to be disabled
-- when turning off 'line input' processing. Notice that turning off
-- 'line input' implies enter/return is reported as '\r' (and it won't
-- report that character until another character is input..odd.) This
-- latter feature doesn't sit too well with IO actions like IO.hGetLine..
-- consider yourself warned.
setCooked :: Int -> Bool -> IO ()
setCooked fd cooked = do
  x <- set_console_buffering (fromIntegral fd) (if cooked then 1 else 0)
  if (x /= 0)
   then ioException (ioe_unk_error "setCooked" "failed to set buffering")
   else return ()

ioe_unk_error loc msg 
 = IOError Nothing OtherError loc msg Nothing

-- Note: echoing goes hand in hand with enabling 'line input' / raw-ness
-- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.
setEcho :: Int -> Bool -> IO ()
setEcho fd on = do
  x <- set_console_echo (fromIntegral fd) (if on then 1 else 0)
  if (x /= 0)
   then ioException (ioe_unk_error "setEcho" "failed to set echoing")
   else return ()

getEcho :: Int -> IO Bool
getEcho fd = do
  r <- get_console_echo (fromIntegral fd)
  if (r == (-1))
   then ioException (ioe_unk_error "getEcho" "failed to get echoing")
   else return (r == 1)

foreign import ccall unsafe "consUtils.h set_console_buffering__"
   set_console_buffering :: CInt -> CInt -> IO CInt

foreign import ccall unsafe "consUtils.h set_console_echo__"
   set_console_echo :: CInt -> CInt -> IO CInt

foreign import ccall unsafe "consUtils.h get_console_echo__"
   get_console_echo :: CInt -> IO CInt

#endif

-- ---------------------------------------------------------------------------
-- Turning on non-blocking for a file descriptor

hugs98-Nov2003/fptools/libraries/base/System/Posix/Internals.hs  view on Meta::CPAN

foreign import ccall unsafe "HsBase.h waitpid"
   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
#else
foreign import ccall unsafe "HsBase.h _setmode"
   c__setmode :: CInt -> CInt -> IO CInt

--   /* Set "stdin" to have binary mode: */
--   result = _setmode( _fileno( stdin ), _O_BINARY );
--   if( result == -1 )
--      perror( "Cannot set mode" );
--   else
--      printf( "'stdin' successfully changed to binary mode\n" );
#endif

-- traversing directories
foreign import ccall unsafe "dirUtils.h __hscore_readdir"
  readdir  :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
 
foreign import ccall unsafe "HsBase.h __hscore_free_dirent"
  freeDirEnt  :: Ptr CDirent -> IO ()
 
foreign import ccall unsafe "HsBase.h __hscore_end_of_dir"
  end_of_dir :: CInt
 
foreign import ccall unsafe "HsBase.h __hscore_d_name"
  d_name :: Ptr CDirent -> IO CString

-- POSIX flags only:
foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_rdwr"   o_RDWR   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_creat"  o_CREAT  :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_excl"   o_EXCL   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_trunc"  o_TRUNC  :: CInt

-- non-POSIX flags.
foreign import ccall unsafe "HsBase.h __hscore_o_noctty"   o_NOCTTY   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_nonblock" o_NONBLOCK :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_binary"   o_BINARY   :: CInt

foreign import ccall unsafe "HsBase.h __hscore_s_isreg"  s_isreg  :: CMode -> Bool
foreign import ccall unsafe "HsBase.h __hscore_s_ischr"  s_ischr  :: CMode -> Bool
foreign import ccall unsafe "HsBase.h __hscore_s_isblk"  s_isblk  :: CMode -> Bool
foreign import ccall unsafe "HsBase.h __hscore_s_isdir"  s_isdir  :: CMode -> Bool
foreign import ccall unsafe "HsBase.h __hscore_s_isfifo" s_isfifo :: CMode -> Bool

foreign import ccall unsafe "HsBase.h __hscore_sizeof_stat" sizeof_stat :: Int
foreign import ccall unsafe "HsBase.h __hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime
foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO COff
foreign import ccall unsafe "HsBase.h __hscore_st_mode" st_mode :: Ptr CStat -> IO CMode

foreign import ccall unsafe "HsBase.h __hscore_echo"         const_echo :: CInt
foreign import ccall unsafe "HsBase.h __hscore_tcsanow"      const_tcsanow :: CInt
foreign import ccall unsafe "HsBase.h __hscore_icanon"       const_icanon :: CInt
foreign import ccall unsafe "HsBase.h __hscore_vmin"         const_vmin   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_vtime"        const_vtime  :: CInt
foreign import ccall unsafe "HsBase.h __hscore_sigttou"      const_sigttou :: CInt
foreign import ccall unsafe "HsBase.h __hscore_sig_block"    const_sig_block :: CInt
foreign import ccall unsafe "HsBase.h __hscore_sig_setmask"  const_sig_setmask :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_getfl"      const_f_getfl :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_setfl"      const_f_setfl :: CInt

#if defined(HTYPE_TCFLAG_T)
foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios"  sizeof_termios :: Int
foreign import ccall unsafe "HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t :: Int

foreign import ccall unsafe "HsBase.h __hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
foreign import ccall unsafe "HsBase.h __hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc  :: Ptr CTermios -> IO (Ptr Word8)
#endif

#if !defined(mingw32_TARGET_OS) && !defined(__MINGW32__)
foreign import ccall unsafe "HsBase.h __hscore_s_issock" s_issock :: CMode -> Bool
#else
s_issock :: CMode -> Bool
s_issock cmode = False
#endif