86a03a9a69e6ed126799f7e651443fff23d42262
[packages/unix.git] / System / Posix / Terminal / Common.hsc
1 {-# LANGUAGE CApiFFI #-}
2 {-# LANGUAGE Trustworthy #-}
3
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module      :  System.Posix.Terminal.Common
7 -- Copyright   :  (c) The University of Glasgow 2002
8 -- License     :  BSD-style (see the file libraries/base/LICENSE)
9 --
10 -- Maintainer  :  libraries@haskell.org
11 -- Stability   :  provisional
12 -- Portability :  non-portable (requires POSIX)
13 --
14 -- POSIX Terminal support
15 --
16 -----------------------------------------------------------------------------
17
18 -- see https://android.googlesource.com/platform/bionic/+/9ae59c0/libc/bionic/pathconf.c#37
19 #if !defined(_POSIX_VDISABLE) && defined(__ANDROID__)
20 #define _POSIX_VDISABLE -1
21 #endif
22
23
24 module System.Posix.Terminal.Common (
25   -- * Terminal support
26
27   -- ** Terminal attributes
28   TerminalAttributes,
29   getTerminalAttributes,
30   TerminalState(..),
31   setTerminalAttributes,
32
33   CTermios,
34   TerminalMode(..),
35   withoutMode,
36   withMode,
37   terminalMode,
38   bitsPerByte,
39   withBits,
40
41   ControlCharacter(..),
42   controlChar,
43   withCC,
44   withoutCC,
45
46   inputTime,
47   withTime,
48   minInput,
49   withMinInput,
50
51   BaudRate(..),
52   inputSpeed,
53   withInputSpeed,
54   outputSpeed,
55   withOutputSpeed,
56
57   -- ** Terminal operations
58   sendBreak,
59   drainOutput,
60   QueueSelector(..),
61   discardData,
62   FlowAction(..),
63   controlFlow,
64
65   -- ** Process groups
66   getTerminalProcessGroupID,
67   setTerminalProcessGroupID,
68
69   -- ** Testing a file descriptor
70   queryTerminal,
71   ) where
72
73 #include "HsUnix.h"
74
75 import Data.Bits
76 import Data.Char
77 import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ )
78 import Foreign.C.Types
79 import Foreign.ForeignPtr ( ForeignPtr, withForeignPtr, mallocForeignPtrBytes )
80 import Foreign.Marshal.Utils ( copyBytes )
81 import Foreign.Ptr ( Ptr, plusPtr )
82 import Foreign.Storable ( Storable(..) )
83 import System.IO.Unsafe ( unsafePerformIO )
84 import System.Posix.Types
85 import System.Posix.Internals ( CTermios )
86
87 #if !HAVE_TCDRAIN
88 import System.IO.Error ( ioeSetLocation )
89 import GHC.IO.Exception ( unsupportedOperation )
90 #endif
91
92 -- -----------------------------------------------------------------------------
93 -- Terminal attributes
94
95 newtype TerminalAttributes = TerminalAttributes (ForeignPtr CTermios)
96
97 makeTerminalAttributes :: ForeignPtr CTermios -> TerminalAttributes
98 makeTerminalAttributes = TerminalAttributes
99
100 withTerminalAttributes :: TerminalAttributes -> (Ptr CTermios -> IO a) -> IO a
101 withTerminalAttributes (TerminalAttributes termios) = withForeignPtr termios
102
103
104 data TerminalMode
105         -- input flags
106    = InterruptOnBreak           -- ^ BRKINT
107    | MapCRtoLF                  -- ^ ICRNL
108    | IgnoreBreak                -- ^ IGNBRK
109    | IgnoreCR                   -- ^ IGNCR
110    | IgnoreParityErrors         -- ^ IGNPAR
111    | MapLFtoCR                  -- ^ INLCR
112    | CheckParity                -- ^ INPCK
113    | StripHighBit               -- ^ ISTRIP
114    | StartStopInput             -- ^ IXOFF
115    | StartStopOutput            -- ^ IXON
116    | MarkParityErrors           -- ^ PARMRK
117
118         -- output flags
119    | ProcessOutput              -- ^ OPOST
120    | MapLFtoCRLF                -- ^ ONLCR
121    | OutputMapCRtoLF            -- ^ OCRNL
122    | NoCRAtColumnZero           -- ^ ONOCR
123    | ReturnMeansLF              -- ^ ONLRET
124    | FillIsDEL                  -- ^ OFDEL
125    | SendFillOnDelay            -- ^ OFILL
126    | LFDelayMask0               -- ^ NLDLY(NL0)
127    | LFDelayMask1               -- ^ NLDLY(NL1)
128    | CRDelayMask0               -- ^ CRDLY(CR0)
129    | CRDelayMask1               -- ^ CRDLY(CR1)
130    | CRDelayMask2               -- ^ CRDLY(CR2)
131    | CRDelayMask3               -- ^ CRDLY(CR3)
132    | TabDelayMask0              -- ^ TABDLY(TAB0)
133    | TabDelayMask1              -- ^ TABDLY(TAB1)
134    | TabDelayMask2              -- ^ TABDLY(TAB2)
135    | TabDelayMask3              -- ^ TABDLY(TAB3)
136    | BackspaceDelayMask0        -- ^ BSDLY(BS0)
137    | BackspaceDelayMask1        -- ^ BSDLY(BS1)
138    | VerticalTabDelayMask0      -- ^ VTDLY(VT0)
139    | VerticalTabDelayMask1      -- ^ VTDLY(VT1)
140    | FormfeedDelayMask0         -- ^ FFDLY(FF0)
141    | FormfeedDelayMask1         -- ^ FFDLY(FF1)
142
143         -- control flags
144    | LocalMode                  -- ^ CLOCAL
145    | ReadEnable                 -- ^ CREAD
146    | TwoStopBits                -- ^ CSTOPB
147    | HangupOnClose              -- ^ HUPCL
148    | EnableParity               -- ^ PARENB
149    | OddParity                  -- ^ PARODD
150
151         -- local modes
152    | EnableEcho                 -- ^ ECHO
153    | EchoErase                  -- ^ ECHOE
154    | EchoKill                   -- ^ ECHOK
155    | EchoLF                     -- ^ ECHONL
156    | ProcessInput               -- ^ ICANON
157    | ExtendedFunctions          -- ^ IEXTEN
158    | KeyboardInterrupts         -- ^ ISIG
159    | NoFlushOnInterrupt         -- ^ NOFLSH
160    | BackgroundWriteInterrupt   -- ^ TOSTOP
161
162 withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
163 withoutMode termios InterruptOnBreak = clearInputFlag (#const BRKINT) termios
164 withoutMode termios MapCRtoLF = clearInputFlag (#const ICRNL) termios
165 withoutMode termios IgnoreBreak = clearInputFlag (#const IGNBRK) termios
166 withoutMode termios IgnoreCR = clearInputFlag (#const IGNCR) termios
167 withoutMode termios IgnoreParityErrors = clearInputFlag (#const IGNPAR) termios
168 withoutMode termios MapLFtoCR = clearInputFlag (#const INLCR) termios
169 withoutMode termios CheckParity = clearInputFlag (#const INPCK) termios
170 withoutMode termios StripHighBit = clearInputFlag (#const ISTRIP) termios
171 withoutMode termios StartStopInput = clearInputFlag (#const IXOFF) termios
172 withoutMode termios StartStopOutput = clearInputFlag (#const IXON) termios
173 withoutMode termios MarkParityErrors = clearInputFlag (#const PARMRK) termios
174 withoutMode termios ProcessOutput = clearOutputFlag (#const OPOST) termios
175 withoutMode termios MapLFtoCRLF = clearOutputFlag (#const ONLCR) termios
176 withoutMode termios OutputMapCRtoLF = clearOutputFlag (#const OCRNL) termios
177 withoutMode termios NoCRAtColumnZero = clearOutputFlag (#const ONOCR) termios
178 withoutMode termios ReturnMeansLF = clearOutputFlag (#const ONLRET) termios
179 withoutMode termios FillIsDEL = clearOutputFlag (#const OFDEL) termios
180 withoutMode termios SendFillOnDelay = clearOutputFlag (#const OFILL) termios
181 withoutMode termios LFDelayMask0 = clearOutputFlag (#const NL0) termios
182 withoutMode termios LFDelayMask1 = clearOutputFlag (#const NL1) termios
183 withoutMode termios CRDelayMask0 = clearOutputFlag (#const CR0) termios
184 withoutMode termios CRDelayMask1 = clearOutputFlag (#const CR1) termios
185 withoutMode termios CRDelayMask2 = clearOutputFlag (#const CR2) termios
186 withoutMode termios CRDelayMask3 = clearOutputFlag (#const CR3) termios
187 withoutMode termios TabDelayMask0 = clearOutputFlag (#const TAB0) termios
188 withoutMode termios TabDelayMask1 = clearOutputFlag (#const TAB1) termios
189 withoutMode termios TabDelayMask2 = clearOutputFlag (#const TAB2) termios
190 withoutMode termios TabDelayMask3 = clearOutputFlag (#const TAB3) termios
191 withoutMode termios BackspaceDelayMask0 = clearOutputFlag (#const BS0) termios
192 withoutMode termios BackspaceDelayMask1 = clearOutputFlag (#const BS1) termios
193 withoutMode termios VerticalTabDelayMask0 = clearOutputFlag (#const VT0) termios
194 withoutMode termios VerticalTabDelayMask1 = clearOutputFlag (#const VT1) termios
195 withoutMode termios FormfeedDelayMask0 = clearOutputFlag (#const FF0) termios
196 withoutMode termios FormfeedDelayMask1 = clearOutputFlag (#const FF1) termios
197 withoutMode termios LocalMode = clearControlFlag (#const CLOCAL) termios
198 withoutMode termios ReadEnable = clearControlFlag (#const CREAD) termios
199 withoutMode termios TwoStopBits = clearControlFlag (#const CSTOPB) termios
200 withoutMode termios HangupOnClose = clearControlFlag (#const HUPCL) termios
201 withoutMode termios EnableParity = clearControlFlag (#const PARENB) termios
202 withoutMode termios OddParity = clearControlFlag (#const PARODD) termios
203 withoutMode termios EnableEcho = clearLocalFlag (#const ECHO) termios
204 withoutMode termios EchoErase = clearLocalFlag (#const ECHOE) termios
205 withoutMode termios EchoKill = clearLocalFlag (#const ECHOK) termios
206 withoutMode termios EchoLF = clearLocalFlag (#const ECHONL) termios
207 withoutMode termios ProcessInput = clearLocalFlag (#const ICANON) termios
208 withoutMode termios ExtendedFunctions = clearLocalFlag (#const IEXTEN) termios
209 withoutMode termios KeyboardInterrupts = clearLocalFlag (#const ISIG) termios
210 withoutMode termios NoFlushOnInterrupt = setLocalFlag (#const NOFLSH) termios
211 withoutMode termios BackgroundWriteInterrupt = clearLocalFlag (#const TOSTOP) termios
212
213 withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
214 withMode termios InterruptOnBreak = setInputFlag (#const BRKINT) termios
215 withMode termios MapCRtoLF = setInputFlag (#const ICRNL) termios
216 withMode termios IgnoreBreak = setInputFlag (#const IGNBRK) termios
217 withMode termios IgnoreCR = setInputFlag (#const IGNCR) termios
218 withMode termios IgnoreParityErrors = setInputFlag (#const IGNPAR) termios
219 withMode termios MapLFtoCR = setInputFlag (#const INLCR) termios
220 withMode termios CheckParity = setInputFlag (#const INPCK) termios
221 withMode termios StripHighBit = setInputFlag (#const ISTRIP) termios
222 withMode termios StartStopInput = setInputFlag (#const IXOFF) termios
223 withMode termios StartStopOutput = setInputFlag (#const IXON) termios
224 withMode termios MarkParityErrors = setInputFlag (#const PARMRK) termios
225 withMode termios ProcessOutput = setOutputFlag (#const OPOST) termios
226 withMode termios MapLFtoCRLF = setOutputFlag (#const ONLCR) termios
227 withMode termios OutputMapCRtoLF = setOutputFlag (#const OCRNL) termios
228 withMode termios NoCRAtColumnZero = setOutputFlag (#const ONOCR) termios
229 withMode termios ReturnMeansLF = setOutputFlag (#const ONLRET) termios
230 withMode termios FillIsDEL = setOutputFlag (#const OFDEL) termios
231 withMode termios SendFillOnDelay = setOutputFlag (#const OFILL) termios
232 withMode termios LFDelayMask0 = setOutputFlag (#const NL0) termios
233 withMode termios LFDelayMask1 = setOutputFlag (#const NL1) termios
234 withMode termios CRDelayMask0 = setOutputFlag (#const CR0) termios
235 withMode termios CRDelayMask1 = setOutputFlag (#const CR1) termios
236 withMode termios CRDelayMask2 = setOutputFlag (#const CR2) termios
237 withMode termios CRDelayMask3 = setOutputFlag (#const CR3) termios
238 withMode termios TabDelayMask0 = setOutputFlag (#const TAB0) termios
239 withMode termios TabDelayMask1 = setOutputFlag (#const TAB1) termios
240 withMode termios TabDelayMask2 = setOutputFlag (#const TAB2) termios
241 withMode termios TabDelayMask3 = setOutputFlag (#const TAB3) termios
242 withMode termios BackspaceDelayMask0 = setOutputFlag (#const BS0) termios
243 withMode termios BackspaceDelayMask1 = setOutputFlag (#const BS1) termios
244 withMode termios VerticalTabDelayMask0 = setOutputFlag (#const VT0) termios
245 withMode termios VerticalTabDelayMask1 = setOutputFlag (#const VT1) termios
246 withMode termios FormfeedDelayMask0 = setOutputFlag (#const FF0) termios
247 withMode termios FormfeedDelayMask1 = setOutputFlag (#const FF1) termios
248 withMode termios LocalMode = setControlFlag (#const CLOCAL) termios
249 withMode termios ReadEnable = setControlFlag (#const CREAD) termios
250 withMode termios TwoStopBits = setControlFlag (#const CSTOPB) termios
251 withMode termios HangupOnClose = setControlFlag (#const HUPCL) termios
252 withMode termios EnableParity = setControlFlag (#const PARENB) termios
253 withMode termios OddParity = setControlFlag (#const PARODD) termios
254 withMode termios EnableEcho = setLocalFlag (#const ECHO) termios
255 withMode termios EchoErase = setLocalFlag (#const ECHOE) termios
256 withMode termios EchoKill = setLocalFlag (#const ECHOK) termios
257 withMode termios EchoLF = setLocalFlag (#const ECHONL) termios
258 withMode termios ProcessInput = setLocalFlag (#const ICANON) termios
259 withMode termios ExtendedFunctions = setLocalFlag (#const IEXTEN) termios
260 withMode termios KeyboardInterrupts = setLocalFlag (#const ISIG) termios
261 withMode termios NoFlushOnInterrupt = clearLocalFlag (#const NOFLSH) termios
262 withMode termios BackgroundWriteInterrupt = setLocalFlag (#const TOSTOP) termios
263
264 terminalMode :: TerminalMode -> TerminalAttributes -> Bool
265 terminalMode InterruptOnBreak = testInputFlag (#const BRKINT)
266 terminalMode MapCRtoLF = testInputFlag (#const ICRNL)
267 terminalMode IgnoreBreak = testInputFlag (#const IGNBRK)
268 terminalMode IgnoreCR = testInputFlag (#const IGNCR)
269 terminalMode IgnoreParityErrors = testInputFlag (#const IGNPAR)
270 terminalMode MapLFtoCR = testInputFlag (#const INLCR)
271 terminalMode CheckParity = testInputFlag (#const INPCK)
272 terminalMode StripHighBit = testInputFlag (#const ISTRIP)
273 terminalMode StartStopInput = testInputFlag (#const IXOFF)
274 terminalMode StartStopOutput = testInputFlag (#const IXON)
275 terminalMode MarkParityErrors = testInputFlag (#const PARMRK)
276 terminalMode ProcessOutput = testOutputFlag (#const OPOST)
277 terminalMode MapLFtoCRLF = testOutputFlag (#const ONLCR)
278 terminalMode OutputMapCRtoLF = testOutputFlag (#const OCRNL)
279 terminalMode NoCRAtColumnZero = testOutputFlag (#const ONOCR)
280 terminalMode ReturnMeansLF = testOutputFlag (#const ONLRET)
281 terminalMode FillIsDEL = testOutputFlag (#const OFDEL)
282 terminalMode SendFillOnDelay = testOutputFlag (#const OFILL)
283 terminalMode LFDelayMask0 = testOutputFlag (#const NL0)
284 terminalMode LFDelayMask1 = testOutputFlag (#const NL1)
285 terminalMode CRDelayMask0 = testOutputFlag (#const CR0)
286 terminalMode CRDelayMask1 = testOutputFlag (#const CR1)
287 terminalMode CRDelayMask2 = testOutputFlag (#const CR2)
288 terminalMode CRDelayMask3 = testOutputFlag (#const CR3)
289 terminalMode TabDelayMask0 = testOutputFlag (#const TAB0)
290 terminalMode TabDelayMask1 = testOutputFlag (#const TAB1)
291 terminalMode TabDelayMask2 = testOutputFlag (#const TAB2)
292 terminalMode TabDelayMask3 = testOutputFlag (#const TAB3)
293 terminalMode BackspaceDelayMask0 = testOutputFlag (#const BS0)
294 terminalMode BackspaceDelayMask1 = testOutputFlag (#const BS1)
295 terminalMode VerticalTabDelayMask0 = testOutputFlag (#const VT0)
296 terminalMode VerticalTabDelayMask1 = testOutputFlag (#const VT1)
297 terminalMode FormfeedDelayMask0 = testOutputFlag (#const FF0)
298 terminalMode FormfeedDelayMask1 = testOutputFlag (#const FF1)
299 terminalMode LocalMode = testControlFlag (#const CLOCAL)
300 terminalMode ReadEnable = testControlFlag (#const CREAD)
301 terminalMode TwoStopBits = testControlFlag (#const CSTOPB)
302 terminalMode HangupOnClose = testControlFlag (#const HUPCL)
303 terminalMode EnableParity = testControlFlag (#const PARENB)
304 terminalMode OddParity = testControlFlag (#const PARODD)
305 terminalMode EnableEcho = testLocalFlag (#const ECHO)
306 terminalMode EchoErase = testLocalFlag (#const ECHOE)
307 terminalMode EchoKill = testLocalFlag (#const ECHOK)
308 terminalMode EchoLF = testLocalFlag (#const ECHONL)
309 terminalMode ProcessInput = testLocalFlag (#const ICANON)
310 terminalMode ExtendedFunctions = testLocalFlag (#const IEXTEN)
311 terminalMode KeyboardInterrupts = testLocalFlag (#const ISIG)
312 terminalMode NoFlushOnInterrupt = not . testLocalFlag (#const NOFLSH)
313 terminalMode BackgroundWriteInterrupt = testLocalFlag (#const TOSTOP)
314
315 bitsPerByte :: TerminalAttributes -> Int
316 bitsPerByte termios = unsafePerformIO $ do
317   withTerminalAttributes termios $ \p -> do
318     cflag <- (#peek struct termios, c_cflag) p
319     return $! (word2Bits (cflag .&. (#const CSIZE)))
320   where
321     word2Bits :: CTcflag -> Int
322     word2Bits x =
323         if x == (#const CS5) then 5
324         else if x == (#const CS6) then 6
325         else if x == (#const CS7) then 7
326         else if x == (#const CS8) then 8
327         else 0
328
329 withBits :: TerminalAttributes -> Int -> TerminalAttributes
330 withBits termios bits = unsafePerformIO $ do
331   withNewTermios termios $ \p -> do
332     cflag <- (#peek struct termios, c_cflag) p
333     (#poke struct termios, c_cflag) p
334        ((cflag .&. complement (#const CSIZE)) .|. mask bits)
335   where
336     mask :: Int -> CTcflag
337     mask 5 = (#const CS5)
338     mask 6 = (#const CS6)
339     mask 7 = (#const CS7)
340     mask 8 = (#const CS8)
341     mask _ = error "withBits bit value out of range [5..8]"
342
343 data ControlCharacter
344   = EndOfFile           -- VEOF
345   | EndOfLine           -- VEOL
346   | Erase               -- VERASE
347   | Interrupt           -- VINTR
348   | Kill                -- VKILL
349   | Quit                -- VQUIT
350   | Start               -- VSTART
351   | Stop                -- VSTOP
352   | Suspend             -- VSUSP
353
354 controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char
355 controlChar termios cc = unsafePerformIO $ do
356   withTerminalAttributes termios $ \p -> do
357     let c_cc = (#ptr struct termios, c_cc) p
358     val <- peekElemOff c_cc (cc2Word cc)
359     if val == ((#const _POSIX_VDISABLE)::CCc)
360        then return Nothing
361        else return (Just (chr (fromEnum val)))
362
363 withCC :: TerminalAttributes
364        -> (ControlCharacter, Char)
365        -> TerminalAttributes
366 withCC termios (cc, c) = unsafePerformIO $ do
367   withNewTermios termios $ \p -> do
368     let c_cc = (#ptr struct termios, c_cc) p
369     pokeElemOff c_cc (cc2Word cc) (fromIntegral (ord c) :: CCc)
370
371 withoutCC :: TerminalAttributes
372           -> ControlCharacter
373           -> TerminalAttributes
374 withoutCC termios cc = unsafePerformIO $ do
375   withNewTermios termios $ \p -> do
376     let c_cc = (#ptr struct termios, c_cc) p
377     pokeElemOff c_cc (cc2Word cc) ((#const _POSIX_VDISABLE) :: CCc)
378
379 inputTime :: TerminalAttributes -> Int
380 inputTime termios = unsafePerformIO $ do
381   withTerminalAttributes termios $ \p -> do
382     c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VTIME)
383     return (fromEnum (c :: CCc))
384
385 withTime :: TerminalAttributes -> Int -> TerminalAttributes
386 withTime termios time = unsafePerformIO $ do
387   withNewTermios termios $ \p -> do
388     let c_cc = (#ptr struct termios, c_cc) p
389     pokeElemOff c_cc (#const VTIME) (fromIntegral time :: CCc)
390
391 minInput :: TerminalAttributes -> Int
392 minInput termios = unsafePerformIO $ do
393   withTerminalAttributes termios $ \p -> do
394     c <- peekElemOff ((#ptr struct termios, c_cc) p) (#const VMIN)
395     return (fromEnum (c :: CCc))
396
397 withMinInput :: TerminalAttributes -> Int -> TerminalAttributes
398 withMinInput termios count = unsafePerformIO $ do
399   withNewTermios termios $ \p -> do
400     let c_cc = (#ptr struct termios, c_cc) p
401     pokeElemOff c_cc (#const VMIN) (fromIntegral count :: CCc)
402
403 data BaudRate
404   = B0
405   | B50
406   | B75
407   | B110
408   | B134
409   | B150
410   | B200
411   | B300
412   | B600
413   | B1200
414   | B1800
415   | B2400
416   | B4800
417   | B9600
418   | B19200
419   | B38400
420   | B57600
421   | B115200
422
423 inputSpeed :: TerminalAttributes -> BaudRate
424 inputSpeed termios = unsafePerformIO $ do
425   withTerminalAttributes termios $ \p -> do
426     w <- c_cfgetispeed p
427     return (word2Baud w)
428
429 foreign import capi unsafe "termios.h cfgetispeed"
430   c_cfgetispeed :: Ptr CTermios -> IO CSpeed
431
432 withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
433 withInputSpeed termios br = unsafePerformIO $ do
434   withNewTermios termios $ \p -> c_cfsetispeed p (baud2Word br)
435
436 foreign import capi unsafe "termios.h cfsetispeed"
437   c_cfsetispeed :: Ptr CTermios -> CSpeed -> IO CInt
438
439
440 outputSpeed :: TerminalAttributes -> BaudRate
441 outputSpeed termios = unsafePerformIO $ do
442   withTerminalAttributes termios $ \p ->  do
443     w <- c_cfgetospeed p
444     return (word2Baud w)
445
446 foreign import capi unsafe "termios.h cfgetospeed"
447   c_cfgetospeed :: Ptr CTermios -> IO CSpeed
448
449 withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
450 withOutputSpeed termios br = unsafePerformIO $ do
451   withNewTermios termios $ \p -> c_cfsetospeed p (baud2Word br)
452
453 foreign import capi unsafe "termios.h cfsetospeed"
454   c_cfsetospeed :: Ptr CTermios -> CSpeed -> IO CInt
455
456 -- | @getTerminalAttributes fd@ calls @tcgetattr@ to obtain
457 --   the @TerminalAttributes@ associated with @Fd@ @fd@.
458 getTerminalAttributes :: Fd -> IO TerminalAttributes
459 getTerminalAttributes (Fd fd) = do
460   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
461   withForeignPtr fp $ \p ->
462       throwErrnoIfMinus1_ "getTerminalAttributes" (c_tcgetattr fd p)
463   return $ makeTerminalAttributes fp
464
465 foreign import capi unsafe "termios.h tcgetattr"
466   c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt
467
468 data TerminalState
469   = Immediately
470   | WhenDrained
471   | WhenFlushed
472
473 -- | @setTerminalAttributes fd attr ts@ calls @tcsetattr@ to change
474 --   the @TerminalAttributes@ associated with @Fd@ @fd@ to
475 --   @attr@, when the terminal is in the state indicated by @ts@.
476 setTerminalAttributes :: Fd
477                       -> TerminalAttributes
478                       -> TerminalState
479                       -> IO ()
480 setTerminalAttributes (Fd fd) termios state = do
481   withTerminalAttributes termios $ \p ->
482     throwErrnoIfMinus1_ "setTerminalAttributes"
483       (c_tcsetattr fd (state2Int state) p)
484   where
485     state2Int :: TerminalState -> CInt
486     state2Int Immediately = (#const TCSANOW)
487     state2Int WhenDrained = (#const TCSADRAIN)
488     state2Int WhenFlushed = (#const TCSAFLUSH)
489
490 foreign import capi unsafe "termios.h tcsetattr"
491    c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt
492
493 -- | @sendBreak fd duration@ calls @tcsendbreak@ to transmit a
494 --   continuous stream of zero-valued bits on @Fd@ @fd@ for the
495 --   specified implementation-dependent @duration@.
496 sendBreak :: Fd -> Int -> IO ()
497 sendBreak (Fd fd) duration
498   = throwErrnoIfMinus1_ "sendBreak" (c_tcsendbreak fd (fromIntegral duration))
499
500 foreign import capi unsafe "termios.h tcsendbreak"
501   c_tcsendbreak :: CInt -> CInt -> IO CInt
502
503 -- | @drainOutput fd@ calls @tcdrain@ to block until all output
504 --   written to @Fd@ @fd@ has been transmitted.
505 --
506 -- Throws 'IOError' (\"unsupported operation\") if platform does not
507 -- provide @tcdrain(3)@ (use @#if HAVE_TCDRAIN@ CPP guard to
508 -- detect availability).
509 drainOutput :: Fd -> IO ()
510 #if HAVE_TCDRAIN
511 drainOutput (Fd fd) = throwErrnoIfMinus1_ "drainOutput" (c_tcdrain fd)
512
513 foreign import capi safe "termios.h tcdrain"
514   c_tcdrain :: CInt -> IO CInt
515 #else
516 {-# WARNING drainOutput
517     "operation will throw 'IOError' \"unsupported operation\" (CPP guard: @#if HAVE_TCDRAIN@)" #-}
518 drainOutput _ = ioError (ioeSetLocation unsupportedOperation "drainOutput")
519 #endif
520
521 data QueueSelector
522   = InputQueue          -- TCIFLUSH
523   | OutputQueue         -- TCOFLUSH
524   | BothQueues          -- TCIOFLUSH
525
526 -- | @discardData fd queues@ calls @tcflush@ to discard
527 --   pending input and\/or output for @Fd@ @fd@,
528 --   as indicated by the @QueueSelector@ @queues@.
529 discardData :: Fd -> QueueSelector -> IO ()
530 discardData (Fd fd) queue =
531   throwErrnoIfMinus1_ "discardData" (c_tcflush fd (queue2Int queue))
532   where
533     queue2Int :: QueueSelector -> CInt
534     queue2Int InputQueue  = (#const TCIFLUSH)
535     queue2Int OutputQueue = (#const TCOFLUSH)
536     queue2Int BothQueues  = (#const TCIOFLUSH)
537
538 foreign import capi unsafe "termios.h tcflush"
539   c_tcflush :: CInt -> CInt -> IO CInt
540
541 data FlowAction
542   = SuspendOutput       -- ^ TCOOFF
543   | RestartOutput       -- ^ TCOON
544   | TransmitStop        -- ^ TCIOFF
545   | TransmitStart       -- ^ TCION
546
547 -- | @controlFlow fd action@ calls @tcflow@ to control the
548 --   flow of data on @Fd@ @fd@, as indicated by
549 --   @action@.
550 controlFlow :: Fd -> FlowAction -> IO ()
551 controlFlow (Fd fd) action =
552   throwErrnoIfMinus1_ "controlFlow" (c_tcflow fd (action2Int action))
553   where
554     action2Int :: FlowAction -> CInt
555     action2Int SuspendOutput = (#const TCOOFF)
556     action2Int RestartOutput = (#const TCOON)
557     action2Int TransmitStop  = (#const TCIOFF)
558     action2Int TransmitStart = (#const TCION)
559
560 foreign import capi unsafe "termios.h tcflow"
561   c_tcflow :: CInt -> CInt -> IO CInt
562
563 -- | @getTerminalProcessGroupID fd@ calls @tcgetpgrp@ to
564 --   obtain the @ProcessGroupID@ of the foreground process group
565 --   associated with the terminal attached to @Fd@ @fd@.
566 getTerminalProcessGroupID :: Fd -> IO ProcessGroupID
567 getTerminalProcessGroupID (Fd fd) = do
568   throwErrnoIfMinus1 "getTerminalProcessGroupID" (c_tcgetpgrp fd)
569
570 foreign import ccall unsafe "tcgetpgrp"
571   c_tcgetpgrp :: CInt -> IO CPid
572
573 -- | @setTerminalProcessGroupID fd pgid@ calls @tcsetpgrp@ to
574 --   set the @ProcessGroupID@ of the foreground process group
575 --   associated with the terminal attached to @Fd@
576 --   @fd@ to @pgid@.
577 setTerminalProcessGroupID :: Fd -> ProcessGroupID -> IO ()
578 setTerminalProcessGroupID (Fd fd) pgid =
579   throwErrnoIfMinus1_ "setTerminalProcessGroupID" (c_tcsetpgrp fd pgid)
580
581 foreign import ccall unsafe "tcsetpgrp"
582   c_tcsetpgrp :: CInt -> CPid -> IO CInt
583
584 -- -----------------------------------------------------------------------------
585 -- file descriptor queries
586
587 -- | @queryTerminal fd@ calls @isatty@ to determine whether or
588 --   not @Fd@ @fd@ is associated with a terminal.
589 queryTerminal :: Fd -> IO Bool
590 queryTerminal (Fd fd) = do
591   r <- c_isatty fd
592   return (r == 1)
593   -- ToDo: the spec says that it can set errno to EBADF if the result is zero
594
595 foreign import ccall unsafe "isatty"
596   c_isatty :: CInt -> IO CInt
597
598 -- -----------------------------------------------------------------------------
599 -- Local utility functions
600
601 -- Convert Haskell ControlCharacter to Int
602
603 cc2Word :: ControlCharacter -> Int
604 cc2Word EndOfFile = (#const VEOF)
605 cc2Word EndOfLine = (#const VEOL)
606 cc2Word Erase     = (#const VERASE)
607 cc2Word Interrupt = (#const VINTR)
608 cc2Word Kill      = (#const VKILL)
609 cc2Word Quit      = (#const VQUIT)
610 cc2Word Suspend   = (#const VSUSP)
611 cc2Word Start     = (#const VSTART)
612 cc2Word Stop      = (#const VSTOP)
613
614 -- Convert Haskell BaudRate to unsigned integral type (Word)
615
616 baud2Word :: BaudRate -> CSpeed
617 baud2Word B0 = (#const B0)
618 baud2Word B50 = (#const B50)
619 baud2Word B75 = (#const B75)
620 baud2Word B110 = (#const B110)
621 baud2Word B134 = (#const B134)
622 baud2Word B150 = (#const B150)
623 baud2Word B200 = (#const B200)
624 baud2Word B300 = (#const B300)
625 baud2Word B600 = (#const B600)
626 baud2Word B1200 = (#const B1200)
627 baud2Word B1800 = (#const B1800)
628 baud2Word B2400 = (#const B2400)
629 baud2Word B4800 = (#const B4800)
630 baud2Word B9600 = (#const B9600)
631 baud2Word B19200 = (#const B19200)
632 baud2Word B38400 = (#const B38400)
633 #ifdef B57600
634 baud2Word B57600 = (#const B57600)
635 #else
636 baud2Word B57600 = error "B57600 not available on this system"
637 #endif
638 #ifdef B115200
639 baud2Word B115200 = (#const B115200)
640 #else
641 baud2Word B115200 = error "B115200 not available on this system"
642 #endif
643
644 -- And convert a word back to a baud rate
645 -- We really need some cpp macros here.
646
647 word2Baud :: CSpeed -> BaudRate
648 word2Baud x =
649     if x == (#const B0) then B0
650     else if x == (#const B50) then B50
651     else if x == (#const B75) then B75
652     else if x == (#const B110) then B110
653     else if x == (#const B134) then B134
654     else if x == (#const B150) then B150
655     else if x == (#const B200) then B200
656     else if x == (#const B300) then B300
657     else if x == (#const B600) then B600
658     else if x == (#const B1200) then B1200
659     else if x == (#const B1800) then B1800
660     else if x == (#const B2400) then B2400
661     else if x == (#const B4800) then B4800
662     else if x == (#const B9600) then B9600
663     else if x == (#const B19200) then B19200
664     else if x == (#const B38400) then B38400
665 #ifdef B57600
666     else if x == (#const B57600) then B57600
667 #endif
668 #ifdef B115200
669     else if x == (#const B115200) then B115200
670 #endif
671     else error "unknown baud rate"
672
673 -- Clear termios i_flag
674
675 clearInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
676 clearInputFlag flag termios = unsafePerformIO $ do
677   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
678   withForeignPtr fp $ \p1 -> do
679     withTerminalAttributes termios $ \p2 -> do
680       copyBytes p1 p2 (#const sizeof(struct termios))
681       iflag <- (#peek struct termios, c_iflag) p2
682       (#poke struct termios, c_iflag) p1 (iflag .&. complement flag)
683   return $ makeTerminalAttributes fp
684
685 -- Set termios i_flag
686
687 setInputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
688 setInputFlag flag termios = unsafePerformIO $ do
689   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
690   withForeignPtr fp $ \p1 -> do
691     withTerminalAttributes termios $ \p2 -> do
692       copyBytes p1 p2 (#const sizeof(struct termios))
693       iflag <- (#peek struct termios, c_iflag) p2
694       (#poke struct termios, c_iflag) p1 (iflag .|. flag)
695   return $ makeTerminalAttributes fp
696
697 -- Examine termios i_flag
698
699 testInputFlag :: CTcflag -> TerminalAttributes -> Bool
700 testInputFlag flag termios = unsafePerformIO $
701   withTerminalAttributes termios $ \p ->  do
702     iflag <- (#peek struct termios, c_iflag) p
703     return $! ((iflag .&. flag) /= 0)
704
705 -- Clear termios c_flag
706
707 clearControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
708 clearControlFlag flag termios = unsafePerformIO $ do
709   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
710   withForeignPtr fp $ \p1 -> do
711     withTerminalAttributes termios $ \p2 -> do
712       copyBytes p1 p2 (#const sizeof(struct termios))
713       cflag <- (#peek struct termios, c_cflag) p2
714       (#poke struct termios, c_cflag) p1 (cflag .&. complement flag)
715   return $ makeTerminalAttributes fp
716
717 -- Set termios c_flag
718
719 setControlFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
720 setControlFlag flag termios = unsafePerformIO $ do
721   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
722   withForeignPtr fp $ \p1 -> do
723     withTerminalAttributes termios $ \p2 -> do
724       copyBytes p1 p2 (#const sizeof(struct termios))
725       cflag <- (#peek struct termios, c_cflag) p2
726       (#poke struct termios, c_cflag) p1 (cflag .|. flag)
727   return $ makeTerminalAttributes fp
728
729 -- Examine termios c_flag
730
731 testControlFlag :: CTcflag -> TerminalAttributes -> Bool
732 testControlFlag flag termios = unsafePerformIO $
733   withTerminalAttributes termios $ \p -> do
734     cflag <- (#peek struct termios, c_cflag) p
735     return $! ((cflag .&. flag) /= 0)
736
737 -- Clear termios l_flag
738
739 clearLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
740 clearLocalFlag flag termios = unsafePerformIO $ do
741   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
742   withForeignPtr fp $ \p1 -> do
743     withTerminalAttributes termios $ \p2 -> do
744       copyBytes p1 p2 (#const sizeof(struct termios))
745       lflag <- (#peek struct termios, c_lflag) p2
746       (#poke struct termios, c_lflag) p1 (lflag .&. complement flag)
747   return $ makeTerminalAttributes fp
748
749 -- Set termios l_flag
750
751 setLocalFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
752 setLocalFlag flag termios = unsafePerformIO $ do
753   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
754   withForeignPtr fp $ \p1 -> do
755     withTerminalAttributes termios $ \p2 -> do
756       copyBytes p1 p2 (#const sizeof(struct termios))
757       lflag <- (#peek struct termios, c_lflag) p2
758       (#poke struct termios, c_lflag) p1 (lflag .|. flag)
759   return $ makeTerminalAttributes fp
760
761 -- Examine termios l_flag
762
763 testLocalFlag :: CTcflag -> TerminalAttributes -> Bool
764 testLocalFlag flag termios = unsafePerformIO $
765   withTerminalAttributes termios $ \p ->  do
766     lflag <- (#peek struct termios, c_lflag) p
767     return $! ((lflag .&. flag) /= 0)
768
769 -- Clear termios o_flag
770
771 clearOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
772 clearOutputFlag flag termios = unsafePerformIO $ do
773   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
774   withForeignPtr fp $ \p1 -> do
775     withTerminalAttributes termios $ \p2 -> do
776       copyBytes p1 p2 (#const sizeof(struct termios))
777       oflag <- (#peek struct termios, c_oflag) p2
778       (#poke struct termios, c_oflag) p1 (oflag .&. complement flag)
779   return $ makeTerminalAttributes fp
780
781 -- Set termios o_flag
782
783 setOutputFlag :: CTcflag -> TerminalAttributes -> TerminalAttributes
784 setOutputFlag flag termios = unsafePerformIO $ do
785   fp <- mallocForeignPtrBytes (#const sizeof(struct termios))
786   withForeignPtr fp $ \p1 -> do
787     withTerminalAttributes termios $ \p2 -> do
788       copyBytes p1 p2 (#const sizeof(struct termios))
789       oflag <- (#peek struct termios, c_oflag) p2
790       (#poke struct termios, c_oflag) p1 (oflag .|. flag)
791   return $ makeTerminalAttributes fp
792
793 -- Examine termios o_flag
794
795 testOutputFlag :: CTcflag -> TerminalAttributes -> Bool
796 testOutputFlag flag termios = unsafePerformIO $
797   withTerminalAttributes termios $ \p -> do
798     oflag <- (#peek struct termios, c_oflag) p
799     return $! ((oflag .&. flag) /= 0)
800
801 withNewTermios :: TerminalAttributes -> (Ptr CTermios -> IO a)
802   -> IO TerminalAttributes
803 withNewTermios termios action = do
804   fp1 <- mallocForeignPtrBytes (#const sizeof(struct termios))
805   withForeignPtr fp1 $ \p1 -> do
806    withTerminalAttributes termios $ \p2 -> do
807     copyBytes p1 p2 (#const sizeof(struct termios))
808     _ <- action p1
809     return ()
810   return $ makeTerminalAttributes fp1