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