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