fcfa92d0807399139b465ad8c885e2d20ba48dc8
[packages/base.git] / 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 'char8', 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