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