GHC/IO/Handle.hs

   1 {-# LANGUAGE CPP
   2            , NoImplicitPrelude
   3            , RecordWildCards
   4            , NondecreasingIndentation
   5   #-}
   6 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
   7
   8 -----------------------------------------------------------------------------
   9 -- |
  10 -- Module      :  GHC.IO.Handle
  11 -- Copyright   :  (c) The University of Glasgow, 1994-2009
  12 -- License     :  see libraries/base/LICENSE
  13 --
  14 -- Maintainer  :  libraries@haskell.org
  15 -- Stability   :  provisional
  16 -- Portability :  non-portable
  17 --
  18 -- External API for GHC's Handle implementation
  19 --
  20 -----------------------------------------------------------------------------
  21
  22 module GHC.IO.Handle (
  23    Handle,
  24    BufferMode(..),
  25
  26    mkFileHandle, mkDuplexHandle,
  27
  28    hFileSize, hSetFileSize, hIsEOF, hLookAhead,
  29    hSetBuffering, hSetBinaryMode, hSetEncoding, hGetEncoding,
  30    hFlush, hFlushAll, hDuplicate, hDuplicateTo,
  31
  32    hClose, hClose_help,
  33
  34    HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
  35    SeekMode(..), hSeek, hTell,
  36
  37    hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  38    hSetEcho, hGetEcho, hIsTerminalDevice,
  39
  40    hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline,
  41    noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
  42
  43    hShow,
  44
  45    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
  46
  47    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking
  48  ) where
  49
  50 import GHC.IO
  51 import GHC.IO.Exception
  52 import GHC.IO.Encoding
  53 import GHC.IO.Buffer
  54 import GHC.IO.BufferedIO ( BufferedIO )
  55 import GHC.IO.Device as IODevice
  56 import GHC.IO.Handle.Types
  57 import GHC.IO.Handle.Internals
  58 import GHC.IO.Handle.Text
  59 import qualified GHC.IO.BufferedIO as Buffered
  60
  61 import GHC.Base
  62 import GHC.Exception
  63 import GHC.MVar
  64 import GHC.IORef
  65 import GHC.Show
  66 import GHC.Num
  67 import GHC.Real
  68 import Data.Maybe
  69 import Data.Typeable
  70 import Control.Monad
  71
  72 -- ---------------------------------------------------------------------------
  73 -- Closing a handle
  74
  75 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the
  76 -- computation finishes, if @hdl@ is writable its buffer is flushed as
  77 -- for 'hFlush'.
  78 -- Performing 'hClose' on a handle that has already been closed has no effect;
  79 -- doing so is not an error.  All other operations on a closed handle will fail.
  80 -- If 'hClose' fails for any reason, any further operations (apart from
  81 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
  82 -- closed.
  83
  84 hClose :: Handle -> IO ()
  85 hClose h@(FileHandle _ m)     = do
  86   mb_exc <- hClose' h m
  87   hClose_maybethrow mb_exc h
  88 hClose h@(DuplexHandle _ r w) = do
  89   excs <- mapM (hClose' h) [r,w]
  90   hClose_maybethrow (listToMaybe (catMaybes excs)) h
  91
  92 hClose_maybethrow :: Maybe SomeException -> Handle -> IO ()
  93 hClose_maybethrow Nothing  h = return ()
  94 hClose_maybethrow (Just e) h = hClose_rethrow e h
  95
  96 hClose_rethrow :: SomeException -> Handle -> IO ()
  97 hClose_rethrow e h =
  98   case fromException e of
  99     Just ioe -> ioError (augmentIOError ioe "hClose" h)
 100     Nothing  -> throwIO e
 101
 102 hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
 103 hClose' h m = withHandle' "hClose" h m $ hClose_help
 104
 105 -----------------------------------------------------------------------------
 106 -- Detecting and changing the size of a file
 107
 108 -- | For a handle @hdl@ which attached to a physical file,
 109 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
 110
 111 hFileSize :: Handle -> IO Integer
 112 hFileSize handle =
 113     withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
 114     case haType handle_ of
 115       ClosedHandle              -> ioe_closedHandle
 116       SemiClosedHandle          -> ioe_closedHandle
 117       _ -> do flushWriteBuffer handle_
 118               r <- IODevice.getSize dev
 119               if r /= -1
 120                  then return r
 121                  else ioException (IOError Nothing InappropriateType "hFileSize"
 122                                    "not a regular file" Nothing Nothing)
 123
 124
 125 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
 126
 127 hSetFileSize :: Handle -> Integer -> IO ()
 128 hSetFileSize handle size =
 129     withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
 130     case haType handle_ of
 131       ClosedHandle              -> ioe_closedHandle
 132       SemiClosedHandle          -> ioe_closedHandle
 133       _ -> do flushWriteBuffer handle_
 134               IODevice.setSize dev size
 135               return ()
 136
 137 -- ---------------------------------------------------------------------------
 138 -- Detecting the End of Input
 139
 140 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
 141 -- 'True' if no further input can be taken from @hdl@ or for a
 142 -- physical file, if the current I\/O position is equal to the length of
 143 -- the file.  Otherwise, it returns 'False'.
 144 --
 145 -- NOTE: 'hIsEOF' may block, because it has to attempt to read from
 146 -- the stream to determine whether there is any more data to be read.
 147
 148 hIsEOF :: Handle -> IO Bool
 149 hIsEOF handle = wantReadableHandle_ "hIsEOF" handle $ \Handle__{..} -> do
 150
 151   cbuf <- readIORef haCharBuffer
 152   if not (isEmptyBuffer cbuf) then return False else do
 153
 154   bbuf <- readIORef haByteBuffer
 155   if not (isEmptyBuffer bbuf) then return False else do
 156
 157   -- NB. do no decoding, just fill the byte buffer; see #3808
 158   (r,bbuf') <- Buffered.fillReadBuffer haDevice bbuf
 159   if r == 0
 160      then return True
 161      else do writeIORef haByteBuffer bbuf'
 162              return False
 163
 164 -- ---------------------------------------------------------------------------
 165 -- Looking ahead
 166
 167 -- | Computation 'hLookAhead' returns the next character from the handle
 168 -- without removing it from the input buffer, blocking until a character
 169 -- is available.
 170 --
 171 -- This operation may fail with:
 172 --
 173 --  * 'isEOFError' if the end of file has been reached.
 174
 175 hLookAhead :: Handle -> IO Char
 176 hLookAhead handle =
 177   wantReadableHandle_ "hLookAhead"  handle hLookAhead_
 178
 179 -- ---------------------------------------------------------------------------
 180 -- Buffering Operations
 181
 182 -- Three kinds of buffering are supported: line-buffering,
 183 -- block-buffering or no-buffering.  See GHC.IO.Handle for definition and
 184 -- further explanation of what the type represent.
 185
 186 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
 187 -- handle @hdl@ on subsequent reads and writes.
 188 --
 189 -- If the buffer mode is changed from 'BlockBuffering' or
 190 -- 'LineBuffering' to 'NoBuffering', then
 191 --
 192 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
 193 --
 194 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
 195 --
 196 -- This operation may fail with:
 197 --
 198 --  * 'isPermissionError' if the handle has already been used for reading
 199 --    or writing and the implementation does not allow the buffering mode
 200 --    to be changed.
 201
 202 hSetBuffering :: Handle -> BufferMode -> IO ()
 203 hSetBuffering handle mode =
 204   withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do
 205   case haType of
 206     ClosedHandle -> ioe_closedHandle
 207     _ -> do
 208          if mode == haBufferMode then return handle_ else do
 209
 210          -- See [note Buffer Sizing] in GHC.IO.Handle.Types
 211
 212           -- check for errors:
 213           case mode of
 214               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 215               _ -> return ()
 216
 217           -- for input terminals we need to put the terminal into
 218           -- cooked or raw mode depending on the type of buffering.
 219           is_tty <- IODevice.isTerminal haDevice
 220           when (is_tty && isReadableHandleType haType) $
 221                 case mode of
 222 #ifndef mingw32_HOST_OS
 223         -- 'raw' mode under win32 is a bit too specialised (and troublesome
 224         -- for most common uses), so simply disable its use here.
 225                   NoBuffering -> IODevice.setRaw haDevice True
 226 #else
 227                   NoBuffering -> return ()
 228 #endif
 229                   _           -> IODevice.setRaw haDevice False
 230
 231           -- throw away spare buffers, they might be the wrong size
 232           writeIORef haBuffers BufferListNil
 233
 234           return Handle__{ haBufferMode = mode,.. }
 235
 236 -- -----------------------------------------------------------------------------
 237 -- hSetEncoding
 238
 239 -- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding
 240 -- for the handle @hdl@ to @encoding@.  The default encoding when a 'Handle' is
 241 -- created is 'localeEncoding', namely the default encoding for the current
 242 -- locale.
 243 --
 244 -- To create a 'Handle' with no encoding at all, use 'openBinaryFile'.  To
 245 -- stop further encoding or decoding on an existing 'Handle', use
 246 -- 'hSetBinaryMode'.
 247 --
 248 -- 'hSetEncoding' may need to flush buffered data in order to change
 249 -- the encoding.
 250 --
 251 hSetEncoding :: Handle -> TextEncoding -> IO ()
 252 hSetEncoding hdl encoding = do
 253   withAllHandles__ "hSetEncoding" hdl $ \h_@Handle__{..} -> do
 254     flushCharBuffer h_
 255     closeTextCodecs h_
 256     openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do
 257     bbuf <- readIORef haByteBuffer
 258     ref <- newIORef (error "last_decode")
 259     return (Handle__{ haLastDecode = ref,
 260                       haDecoder = mb_decoder,
 261                       haEncoder = mb_encoder,
 262                       haCodec   = Just encoding, .. })
 263
 264 -- | Return the current 'TextEncoding' for the specified 'Handle', or
 265 -- 'Nothing' if the 'Handle' is in binary mode.
 266 --
 267 -- Note that the 'TextEncoding' remembers nothing about the state of
 268 -- the encoder/decoder in use on this 'Handle'.  For example, if the
 269 -- encoding in use is UTF-16, then using 'hGetEncoding' and
 270 -- 'hSetEncoding' to save and restore the encoding may result in an
 271 -- extra byte-order-mark being written to the file.
 272 --
 273 hGetEncoding :: Handle -> IO (Maybe TextEncoding)
 274 hGetEncoding hdl =
 275   withHandle_ "hGetEncoding" hdl $ \h_@Handle__{..} -> return haCodec
 276
 277 -- -----------------------------------------------------------------------------
 278 -- hFlush
 279
 280 -- | The action 'hFlush' @hdl@ causes any items buffered for output
 281 -- in handle @hdl@ to be sent immediately to the operating system.
 282 --
 283 -- This operation may fail with:
 284 --
 285 --  * 'isFullError' if the device is full;
 286 --
 287 --  * 'isPermissionError' if a system resource limit would be exceeded.
 288 --    It is unspecified whether the characters in the buffer are discarded
 289 --    or retained under these circumstances.
 290
 291 hFlush :: Handle -> IO ()
 292 hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
 293
 294 -- | The action 'hFlushAll' @hdl@ flushes all buffered data in @hdl@,
 295 -- including any buffered read data.  Buffered read data is flushed
 296 -- by seeking the file position back to the point before the bufferred
 297 -- data was read, and hence only works if @hdl@ is seekable (see
 298 -- 'hIsSeekable').
 299 --
 300 -- This operation may fail with:
 301 --
 302 --  * 'isFullError' if the device is full;
 303 --
 304 --  * 'isPermissionError' if a system resource limit would be exceeded.
 305 --    It is unspecified whether the characters in the buffer are discarded
 306 --    or retained under these circumstances;
 307 --
 308 --  * 'isIllegalOperation' if @hdl@ has buffered read data, and is not
 309 --    seekable.
 310
 311 hFlushAll :: Handle -> IO ()
 312 hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer
 313
 314 -- -----------------------------------------------------------------------------
 315 -- Repositioning Handles
 316
 317 data HandlePosn = HandlePosn Handle HandlePosition
 318
 319 instance Eq HandlePosn where
 320     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 321
 322 instance Show HandlePosn where
 323    showsPrec p (HandlePosn h pos) =
 324         showsPrec p h . showString " at position " . shows pos
 325
 326   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 327   -- We represent it as an Integer on the Haskell side, but
 328   -- cheat slightly in that hGetPosn calls upon a C helper
 329   -- that reports the position back via (merely) an Int.
 330 type HandlePosition = Integer
 331
 332 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
 333 -- @hdl@ as a value of the abstract type 'HandlePosn'.
 334
 335 hGetPosn :: Handle -> IO HandlePosn
 336 hGetPosn handle = do
 337     posn <- hTell handle
 338     return (HandlePosn handle posn)
 339
 340 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
 341 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
 342 -- to the position it held at the time of the call to 'hGetPosn'.
 343 --
 344 -- This operation may fail with:
 345 --
 346 --  * 'isPermissionError' if a system resource limit would be exceeded.
 347
 348 hSetPosn :: HandlePosn -> IO ()
 349 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 350
 351 -- ---------------------------------------------------------------------------
 352 -- hSeek
 353
 354 {- Note:
 355  - when seeking using `SeekFromEnd', positive offsets (>=0) means
 356    seeking at or past EOF.
 357
 358  - we possibly deviate from the report on the issue of seeking within
 359    the buffer and whether to flush it or not.  The report isn't exactly
 360    clear here.
 361 -}
 362
 363 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
 364 -- @hdl@ depending on @mode@.
 365 -- The offset @i@ is given in terms of 8-bit bytes.
 366 --
 367 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
 368 -- in the current buffer will first cause any items in the output buffer to be
 369 -- written to the device, and then cause the input buffer to be discarded.
 370 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
 371 -- subset of the possible positioning operations (for instance, it may only
 372 -- be possible to seek to the end of a tape, or to a positive offset from
 373 -- the beginning or current position).
 374 -- It is not possible to set a negative I\/O position, or for
 375 -- a physical file, an I\/O position beyond the current end-of-file.
 376 --
 377 -- This operation may fail with:
 378 --
 379 --  * 'isIllegalOperationError' if the Handle is not seekable, or does
 380 --     not support the requested seek mode.
 381 --
 382 --  * 'isPermissionError' if a system resource limit would be exceeded.
 383
 384 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 385 hSeek handle mode offset =
 386     wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do
 387     debugIO ("hSeek " ++ show (mode,offset))
 388     buf <- readIORef haCharBuffer
 389
 390     if isWriteBuffer buf
 391         then do flushWriteBuffer handle_
 392                 IODevice.seek haDevice mode offset
 393         else do
 394
 395     let r = bufL buf; w = bufR buf
 396     if mode == RelativeSeek && isNothing haDecoder &&
 397        offset >= 0 && offset < fromIntegral (w - r)
 398         then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset }
 399         else do
 400
 401     flushCharReadBuffer handle_
 402     flushByteReadBuffer handle_
 403     IODevice.seek haDevice mode offset
 404
 405
 406 -- | Computation 'hTell' @hdl@ returns the current position of the
 407 -- handle @hdl@, as the number of bytes from the beginning of
 408 -- the file.  The value returned may be subsequently passed to
 409 -- 'hSeek' to reposition the handle to the current position.
 410 --
 411 -- This operation may fail with:
 412 --
 413 --  * 'isIllegalOperationError' if the Handle is not seekable.
 414 --
 415 hTell :: Handle -> IO Integer
 416 hTell handle =
 417     wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do
 418
 419       posn <- IODevice.tell haDevice
 420
 421       -- we can't tell the real byte offset if there are buffered
 422       -- Chars, so must flush first:
 423       flushCharBuffer handle_
 424
 425       bbuf <- readIORef haByteBuffer
 426
 427       let real_posn
 428            | isWriteBuffer bbuf = posn + fromIntegral (bufferElems bbuf)
 429            | otherwise          = posn - fromIntegral (bufferElems bbuf)
 430
 431       cbuf <- readIORef haCharBuffer
 432       debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn))
 433       debugIO ("   cbuf: " ++ summaryBuffer cbuf ++
 434             "   bbuf: " ++ summaryBuffer bbuf)
 435
 436       return real_posn
 437
 438 -- -----------------------------------------------------------------------------
 439 -- Handle Properties
 440
 441 -- A number of operations return information about the properties of a
 442 -- handle.  Each of these operations returns `True' if the handle has
 443 -- the specified property, and `False' otherwise.
 444
 445 hIsOpen :: Handle -> IO Bool
 446 hIsOpen handle =
 447     withHandle_ "hIsOpen" handle $ \ handle_ -> do
 448     case haType handle_ of
 449       ClosedHandle         -> return False
 450       SemiClosedHandle     -> return False
 451       _                    -> return True
 452
 453 hIsClosed :: Handle -> IO Bool
 454 hIsClosed handle =
 455     withHandle_ "hIsClosed" handle $ \ handle_ -> do
 456     case haType handle_ of
 457       ClosedHandle         -> return True
 458       _                    -> return False
 459
 460 {- not defined, nor exported, but mentioned
 461    here for documentation purposes:
 462
 463     hSemiClosed :: Handle -> IO Bool
 464     hSemiClosed h = do
 465        ho <- hIsOpen h
 466        hc <- hIsClosed h
 467        return (not (ho || hc))
 468 -}
 469
 470 hIsReadable :: Handle -> IO Bool
 471 hIsReadable (DuplexHandle _ _ _) = return True
 472 hIsReadable handle =
 473     withHandle_ "hIsReadable" handle $ \ handle_ -> do
 474     case haType handle_ of
 475       ClosedHandle         -> ioe_closedHandle
 476       SemiClosedHandle     -> ioe_closedHandle
 477       htype                -> return (isReadableHandleType htype)
 478
 479 hIsWritable :: Handle -> IO Bool
 480 hIsWritable (DuplexHandle _ _ _) = return True
 481 hIsWritable handle =
 482     withHandle_ "hIsWritable" handle $ \ handle_ -> do
 483     case haType handle_ of
 484       ClosedHandle         -> ioe_closedHandle
 485       SemiClosedHandle     -> ioe_closedHandle
 486       htype                -> return (isWritableHandleType htype)
 487
 488 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
 489 -- for @hdl@.
 490
 491 hGetBuffering :: Handle -> IO BufferMode
 492 hGetBuffering handle =
 493     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
 494     case haType handle_ of
 495       ClosedHandle         -> ioe_closedHandle
 496       _ ->
 497            -- We're being non-standard here, and allow the buffering
 498            -- of a semi-closed handle to be queried.   -- sof 6/98
 499           return (haBufferMode handle_)  -- could be stricter..
 500
 501 hIsSeekable :: Handle -> IO Bool
 502 hIsSeekable handle =
 503     withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do
 504     case haType of
 505       ClosedHandle         -> ioe_closedHandle
 506       SemiClosedHandle     -> ioe_closedHandle
 507       AppendHandle         -> return False
 508       _                    -> IODevice.isSeekable haDevice
 509
 510 -- -----------------------------------------------------------------------------
 511 -- Changing echo status (Non-standard GHC extensions)
 512
 513 -- | Set the echoing status of a handle connected to a terminal.
 514
 515 hSetEcho :: Handle -> Bool -> IO ()
 516 hSetEcho handle on = do
 517     isT   <- hIsTerminalDevice handle
 518     if not isT
 519      then return ()
 520      else
 521       withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do
 522       case haType of
 523          ClosedHandle -> ioe_closedHandle
 524          _            -> IODevice.setEcho haDevice on
 525
 526 -- | Get the echoing status of a handle connected to a terminal.
 527
 528 hGetEcho :: Handle -> IO Bool
 529 hGetEcho handle = do
 530     isT   <- hIsTerminalDevice handle
 531     if not isT
 532      then return False
 533      else
 534        withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do
 535        case haType of
 536          ClosedHandle -> ioe_closedHandle
 537          _            -> IODevice.getEcho haDevice
 538
 539 -- | Is the handle connected to a terminal?
 540
 541 hIsTerminalDevice :: Handle -> IO Bool
 542 hIsTerminalDevice handle = do
 543     withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do
 544      case haType of
 545        ClosedHandle -> ioe_closedHandle
 546        _            -> IODevice.isTerminal haDevice
 547
 548 -- -----------------------------------------------------------------------------
 549 -- hSetBinaryMode
 550
 551 -- | Select binary mode ('True') or text mode ('False') on a open handle.
 552 -- (See also 'openBinaryFile'.)
 553 --
 554 -- This has the same effect as calling 'hSetEncoding' with 'latin1', together
 555 -- with 'hSetNewlineMode' with 'noNewlineTranslation'.
 556 --
 557 hSetBinaryMode :: Handle -> Bool -> IO ()
 558 hSetBinaryMode handle bin =
 559   withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} ->
 560     do
 561          flushCharBuffer h_
 562          closeTextCodecs h_
 563
 564          let mb_te | bin       = Nothing
 565                    | otherwise = Just localeEncoding
 566
 567          openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do
 568
 569          -- should match the default newline mode, whatever that is
 570          let nl    | bin       = noNewlineTranslation
 571                    | otherwise = nativeNewlineMode
 572
 573          bbuf <- readIORef haByteBuffer
 574          ref <- newIORef (error "codec_state", bbuf)
 575
 576          return Handle__{ haLastDecode = ref,
 577                           haEncoder  = mb_encoder,
 578                           haDecoder  = mb_decoder,
 579                           haCodec    = mb_te,
 580                           haInputNL  = inputNL nl,
 581                           haOutputNL = outputNL nl, .. }
 582
 583 -- -----------------------------------------------------------------------------
 584 -- hSetNewlineMode
 585
 586 -- | Set the 'NewlineMode' on the specified 'Handle'.  All buffered
 587 -- data is flushed first.
 588 hSetNewlineMode :: Handle -> NewlineMode -> IO ()
 589 hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =
 590   withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} ->
 591     do
 592          flushBuffer h_
 593          return h_{ haInputNL=i, haOutputNL=o }
 594
 595 -- -----------------------------------------------------------------------------
 596 -- Duplicating a Handle
 597
 598 -- | Returns a duplicate of the original handle, with its own buffer.
 599 -- The two Handles will share a file pointer, however.  The original
 600 -- handle's buffer is flushed, including discarding any input data,
 601 -- before the handle is duplicated.
 602
 603 hDuplicate :: Handle -> IO Handle
 604 hDuplicate h@(FileHandle path m) = do
 605   withHandle_' "hDuplicate" h m $ \h_ ->
 606       dupHandle path h Nothing h_ (Just handleFinalizer)
 607 hDuplicate h@(DuplexHandle path r w) = do
 608   write_side@(FileHandle _ write_m) <-
 609      withHandle_' "hDuplicate" h w $ \h_ ->
 610         dupHandle path h Nothing h_ (Just handleFinalizer)
 611   read_side@(FileHandle _ read_m) <-
 612     withHandle_' "hDuplicate" h r $ \h_ ->
 613         dupHandle path h (Just write_m) h_  Nothing
 614   return (DuplexHandle path read_m write_m)
 615
 616 dupHandle :: FilePath
 617           -> Handle
 618           -> Maybe (MVar Handle__)
 619           -> Handle__
 620           -> Maybe HandleFinalizer
 621           -> IO Handle
 622 dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do
 623   -- flush the buffer first, so we don't have to copy its contents
 624   flushBuffer h_
 625   case other_side of
 626     Nothing -> do
 627        new_dev <- IODevice.dup haDevice
 628        dupHandle_ new_dev filepath other_side h_ mb_finalizer
 629     Just r  ->
 630        withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do
 631          dupHandle_ dev filepath other_side h_ mb_finalizer
 632
 633 dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 634            -> FilePath
 635            -> Maybe (MVar Handle__)
 636            -> Handle__
 637            -> Maybe HandleFinalizer
 638            -> IO Handle
 639 dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
 640    -- XXX wrong!
 641   let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing
 642   mkHandle new_dev filepath haType True{-buffered-} mb_codec
 643       NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
 644       mb_finalizer other_side
 645
 646 -- -----------------------------------------------------------------------------
 647 -- Replacing a Handle
 648
 649 {- |
 650 Makes the second handle a duplicate of the first handle.  The second
 651 handle will be closed first, if it is not already.
 652
 653 This can be used to retarget the standard Handles, for example:
 654
 655 > do h <- openFile "mystdout" WriteMode
 656 >    hDuplicateTo h stdout
 657 -}
 658
 659 hDuplicateTo :: Handle -> Handle -> IO ()
 660 hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do
 661  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
 662    _ <- hClose_help h2_
 663    withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
 664      dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
 665 hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do
 666  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
 667    _ <- hClose_help w2_
 668    withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
 669      dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
 670  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
 671    _ <- hClose_help r2_
 672    withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
 673      dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
 674 hDuplicateTo h1 _ =
 675   ioe_dupHandlesNotCompatible h1
 676
 677
 678 ioe_dupHandlesNotCompatible :: Handle -> IO a
 679 ioe_dupHandlesNotCompatible h =
 680    ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
 681                 "handles are incompatible" Nothing Nothing)
 682
 683 dupHandleTo :: FilePath
 684             -> Handle
 685             -> Maybe (MVar Handle__)
 686             -> Handle__
 687             -> Handle__
 688             -> Maybe HandleFinalizer
 689             -> IO Handle__
 690 dupHandleTo filepath h other_side
 691             hto_@Handle__{haDevice=devTo,..}
 692             h_@Handle__{haDevice=dev} mb_finalizer = do
 693   flushBuffer h_
 694   case cast devTo of
 695     Nothing   -> ioe_dupHandlesNotCompatible h
 696     Just dev' -> do
 697       _ <- IODevice.dup2 dev dev'
 698       FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
 699       takeMVar m
 700
 701 -- ---------------------------------------------------------------------------
 702 -- showing Handles.
 703 --
 704 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
 705 -- than the (pure) instance of 'Show' for 'Handle'.
 706
 707 hShow :: Handle -> IO String
 708 hShow h@(FileHandle path _) = showHandle' path False h
 709 hShow h@(DuplexHandle path _ _) = showHandle' path True h
 710
 711 showHandle' :: String -> Bool -> Handle -> IO String
 712 showHandle' filepath is_duplex h =
 713   withHandle_ "showHandle" h $ \hdl_ ->
 714     let
 715      showType | is_duplex = showString "duplex (read-write)"
 716               | otherwise = shows (haType hdl_)
 717     in
 718     return
 719       (( showChar '{' .
 720         showHdl (haType hdl_)
 721             (showString "loc=" . showString filepath . showChar ',' .
 722              showString "type=" . showType . showChar ',' .
 723              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
 724       ) "")
 725    where
 726
 727     showHdl :: HandleType -> ShowS -> ShowS
 728     showHdl ht cont =
 729        case ht of
 730         ClosedHandle  -> shows ht . showString "}"
 731         _ -> cont
 732
 733     showBufMode :: Buffer e -> BufferMode -> ShowS
 734     showBufMode buf bmo =
 735       case bmo of
 736         NoBuffering   -> showString "none"
 737         LineBuffering -> showString "line"
 738         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
 739         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
 740       where
 741        def :: Int
 742        def = bufSize buf