a2b644f51493dea1141eb25531ea54b724cc2ed0
[ghc.git] / libraries / base / GHC / IO / Handle / Internals.hs
1 {-# LANGUAGE NoImplicitPrelude
2 , RecordWildCards
3 , BangPatterns
4 , PatternGuards
5 , NondecreasingIndentation
6 , Rank2Types
7 #-}
8 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
9 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
10 {-# OPTIONS_HADDOCK hide #-}
11
12 -----------------------------------------------------------------------------
13 -- |
14 -- Module : GHC.IO.Handle.Internals
15 -- Copyright : (c) The University of Glasgow, 1994-2001
16 -- License : see libraries/base/LICENSE
17 --
18 -- Maintainer : libraries@haskell.org
19 -- Stability : internal
20 -- Portability : non-portable
21 --
22 -- This module defines the basic operations on I\/O \"handles\". All
23 -- of the operations defined here are independent of the underlying
24 -- device.
25 --
26 -----------------------------------------------------------------------------
27
28 -- #hide
29 module GHC.IO.Handle.Internals (
30 withHandle, withHandle', withHandle_,
31 withHandle__', withHandle_', withAllHandles__,
32 wantWritableHandle, wantReadableHandle, wantReadableHandle_,
33 wantSeekableHandle,
34
35 mkHandle, mkFileHandle, mkDuplexHandle,
36 openTextEncoding, closeTextCodecs, initBufferState,
37 dEFAULT_CHAR_BUFFER_SIZE,
38
39 flushBuffer, flushWriteBuffer, flushCharReadBuffer,
40 flushCharBuffer, flushByteReadBuffer, flushByteWriteBuffer,
41
42 readTextDevice, writeCharBuffer, readTextDeviceNonBlocking,
43 decodeByteBuf,
44
45 augmentIOError,
46 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
47 ioe_finalizedHandle, ioe_bufsiz,
48
49 hClose_help, hLookAhead_,
50
51 HandleFinalizer, handleFinalizer,
52
53 debugIO,
54 ) where
55
56 import GHC.IO
57 import GHC.IO.IOMode
58 import GHC.IO.Encoding as Encoding
59 import GHC.IO.Handle.Types
60 import GHC.IO.Buffer
61 import GHC.IO.BufferedIO (BufferedIO)
62 import GHC.IO.Exception
63 import GHC.IO.Device (IODevice, SeekMode(..))
64 import qualified GHC.IO.Device as IODevice
65 import qualified GHC.IO.BufferedIO as Buffered
66
67 import GHC.Conc.Sync
68 import GHC.Real
69 import GHC.Base
70 import GHC.Exception
71 import GHC.Num ( Num(..) )
72 import GHC.Show
73 import GHC.IORef
74 import GHC.MVar
75 import Data.Typeable
76 import Control.Monad
77 import Data.Maybe
78 import Foreign hiding (unsafePerformIO)
79 -- import System.IO.Error
80 import System.Posix.Internals hiding (FD)
81
82 import Foreign.C
83
84 c_DEBUG_DUMP :: Bool
85 c_DEBUG_DUMP = False
86
87 -- ---------------------------------------------------------------------------
88 -- Creating a new handle
89
90 type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()
91
92 newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle
93 newFileHandle filepath mb_finalizer hc = do
94 m <- newMVar hc
95 case mb_finalizer of
96 Just finalizer -> addMVarFinalizer m (finalizer filepath m)
97 Nothing -> return ()
98 return (FileHandle filepath m)
99
100 -- ---------------------------------------------------------------------------
101 -- Working with Handles
102
103 {-
104 In the concurrent world, handles are locked during use. This is done
105 by wrapping an MVar around the handle which acts as a mutex over
106 operations on the handle.
107
108 To avoid races, we use the following bracketing operations. The idea
109 is to obtain the lock, do some operation and replace the lock again,
110 whether the operation succeeded or failed. We also want to handle the
111 case where the thread receives an exception while processing the IO
112 operation: in these cases we also want to relinquish the lock.
113
114 There are three versions of @withHandle@: corresponding to the three
115 possible combinations of:
116
117 - the operation may side-effect the handle
118 - the operation may return a result
119
120 If the operation generates an error or an exception is raised, the
121 original handle is always replaced.
122 -}
123
124 {-# INLINE withHandle #-}
125 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
126 withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
127 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
128
129 withHandle' :: String -> Handle -> MVar Handle__
130 -> (Handle__ -> IO (Handle__,a)) -> IO a
131 withHandle' fun h m act =
132 mask_ $ do
133 (h',v) <- do_operation fun h act m
134 checkHandleInvariants h'
135 putMVar m h'
136 return v
137
138 {-# INLINE withHandle_ #-}
139 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
140 withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
141 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
142
143 withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
144 withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do
145 a <- act h_
146 return (h_,a)
147
148 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
149 withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
150 withAllHandles__ fun h@(DuplexHandle _ r w) act = do
151 withHandle__' fun h r act
152 withHandle__' fun h w act
153
154 withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
155 -> IO ()
156 withHandle__' fun h m act =
157 mask_ $ do
158 h' <- do_operation fun h act m
159 checkHandleInvariants h'
160 putMVar m h'
161 return ()
162
163 do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a
164 do_operation fun h act m = do
165 h_ <- takeMVar m
166 checkHandleInvariants h_
167 act h_ `catchException` handler h_
168 where
169 handler h_ e = do
170 putMVar m h_
171 case () of
172 _ | Just ioe <- fromException e ->
173 ioError (augmentIOError ioe fun h)
174 _ | Just async_ex <- fromException e -> do -- see Note [async]
175 let _ = async_ex :: AsyncException
176 t <- myThreadId
177 throwTo t e
178 do_operation fun h act m
179 _otherwise ->
180 throwIO e
181
182 -- Note [async]
183 --
184 -- If an asynchronous exception is raised during an I/O operation,
185 -- normally it is fine to just re-throw the exception synchronously.
186 -- However, if we are inside an unsafePerformIO or an
187 -- unsafeInterleaveIO, this would replace the enclosing thunk with the
188 -- exception raised, which is wrong (#3997). We have to release the
189 -- lock on the Handle, but what do we replace the thunk with? What
190 -- should happen when the thunk is subsequently demanded again?
191 --
192 -- The only sensible choice we have is to re-do the IO operation on
193 -- resumption, but then we have to be careful in the IO library that
194 -- this is always safe to do. In particular we should
195 --
196 -- never perform any side-effects before an interruptible operation
197 --
198 -- because the interruptible operation may raise an asynchronous
199 -- exception, which may cause the operation and its side effects to be
200 -- subsequently performed again.
201 --
202 -- Re-doing the IO operation is achieved by:
203 -- - using throwTo to re-throw the asynchronous exception asynchronously
204 -- in the current thread
205 -- - on resumption, it will be as if throwTo returns. In that case, we
206 -- recursively invoke the original operation (see do_operation above).
207 --
208 -- Interruptible operations in the I/O library are:
209 -- - threadWaitRead/threadWaitWrite
210 -- - fillReadBuffer/flushWriteBuffer
211 -- - readTextDevice/writeTextDevice
212
213 augmentIOError :: IOException -> String -> Handle -> IOException
214 augmentIOError ioe@IOError{ ioe_filename = fp } fun h
215 = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }
216 where filepath
217 | Just _ <- fp = fp
218 | otherwise = case h of
219 FileHandle path _ -> Just path
220 DuplexHandle path _ _ -> Just path
221
222 -- ---------------------------------------------------------------------------
223 -- Wrapper for write operations.
224
225 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
226 wantWritableHandle fun h@(FileHandle _ m) act
227 = wantWritableHandle' fun h m act
228 wantWritableHandle fun h@(DuplexHandle _ _ m) act
229 = wantWritableHandle' fun h m act
230 -- we know it's not a ReadHandle or ReadWriteHandle, but we have to
231 -- check for ClosedHandle/SemiClosedHandle. (#4808)
232
233 wantWritableHandle'
234 :: String -> Handle -> MVar Handle__
235 -> (Handle__ -> IO a) -> IO a
236 wantWritableHandle' fun h m act
237 = withHandle_' fun h m (checkWritableHandle act)
238
239 checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
240 checkWritableHandle act h_@Handle__{..}
241 = case haType of
242 ClosedHandle -> ioe_closedHandle
243 SemiClosedHandle -> ioe_closedHandle
244 ReadHandle -> ioe_notWritable
245 ReadWriteHandle -> do
246 buf <- readIORef haCharBuffer
247 when (not (isWriteBuffer buf)) $ do
248 flushCharReadBuffer h_
249 flushByteReadBuffer h_
250 buf <- readIORef haCharBuffer
251 writeIORef haCharBuffer buf{ bufState = WriteBuffer }
252 buf <- readIORef haByteBuffer
253 buf' <- Buffered.emptyWriteBuffer haDevice buf
254 writeIORef haByteBuffer buf'
255 act h_
256 _other -> act h_
257
258 -- ---------------------------------------------------------------------------
259 -- Wrapper for read operations.
260
261 wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
262 wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act)
263
264 wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
265 wantReadableHandle_ fun h@(FileHandle _ m) act
266 = wantReadableHandle' fun h m act
267 wantReadableHandle_ fun h@(DuplexHandle _ m _) act
268 = wantReadableHandle' fun h m act
269 -- we know it's not a WriteHandle or ReadWriteHandle, but we have to
270 -- check for ClosedHandle/SemiClosedHandle. (#4808)
271
272 wantReadableHandle'
273 :: String -> Handle -> MVar Handle__
274 -> (Handle__ -> IO a) -> IO a
275 wantReadableHandle' fun h m act
276 = withHandle_' fun h m (checkReadableHandle act)
277
278 checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
279 checkReadableHandle act h_@Handle__{..} =
280 case haType of
281 ClosedHandle -> ioe_closedHandle
282 SemiClosedHandle -> ioe_closedHandle
283 AppendHandle -> ioe_notReadable
284 WriteHandle -> ioe_notReadable
285 ReadWriteHandle -> do
286 -- a read/write handle and we want to read from it. We must
287 -- flush all buffered write data first.
288 bbuf <- readIORef haByteBuffer
289 when (isWriteBuffer bbuf) $ do
290 when (not (isEmptyBuffer bbuf)) $ flushByteWriteBuffer h_
291 cbuf' <- readIORef haCharBuffer
292 writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }
293 bbuf <- readIORef haByteBuffer
294 writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }
295 act h_
296 _other -> act h_
297
298 -- ---------------------------------------------------------------------------
299 -- Wrapper for seek operations.
300
301 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
302 wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
303 ioException (IOError (Just h) IllegalOperation fun
304 "handle is not seekable" Nothing Nothing)
305 wantSeekableHandle fun h@(FileHandle _ m) act =
306 withHandle_' fun h m (checkSeekableHandle act)
307
308 checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
309 checkSeekableHandle act handle_@Handle__{haDevice=dev} =
310 case haType handle_ of
311 ClosedHandle -> ioe_closedHandle
312 SemiClosedHandle -> ioe_closedHandle
313 AppendHandle -> ioe_notSeekable
314 _ -> do b <- IODevice.isSeekable dev
315 if b then act handle_
316 else ioe_notSeekable
317
318 -- -----------------------------------------------------------------------------
319 -- Handy IOErrors
320
321 ioe_closedHandle, ioe_EOF,
322 ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable,
323 ioe_notSeekable, ioe_invalidCharacter :: IO a
324
325 ioe_closedHandle = ioException
326 (IOError Nothing IllegalOperation ""
327 "handle is closed" Nothing Nothing)
328 ioe_EOF = ioException
329 (IOError Nothing EOF "" "" Nothing Nothing)
330 ioe_notReadable = ioException
331 (IOError Nothing IllegalOperation ""
332 "handle is not open for reading" Nothing Nothing)
333 ioe_notWritable = ioException
334 (IOError Nothing IllegalOperation ""
335 "handle is not open for writing" Nothing Nothing)
336 ioe_notSeekable = ioException
337 (IOError Nothing IllegalOperation ""
338 "handle is not seekable" Nothing Nothing)
339 ioe_cannotFlushNotSeekable = ioException
340 (IOError Nothing IllegalOperation ""
341 "cannot flush the read buffer: underlying device is not seekable"
342 Nothing Nothing)
343 ioe_invalidCharacter = ioException
344 (IOError Nothing InvalidArgument ""
345 ("invalid byte sequence for this encoding") Nothing Nothing)
346
347 ioe_finalizedHandle :: FilePath -> Handle__
348 ioe_finalizedHandle fp = throw
349 (IOError Nothing IllegalOperation ""
350 "handle is finalized" Nothing (Just fp))
351
352 ioe_bufsiz :: Int -> IO a
353 ioe_bufsiz n = ioException
354 (IOError Nothing InvalidArgument "hSetBuffering"
355 ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
356 -- 9 => should be parens'ified.
357
358 -- ---------------------------------------------------------------------------
359 -- Wrapper for Handle encoding/decoding.
360
361 -- The interface for TextEncoding changed so that a TextEncoding doesn't raise
362 -- an exception if it encounters an invalid sequnce. Furthermore, encoding
363 -- returns a reason as to why encoding stopped, letting us know if it was due
364 -- to input/output underflow or an invalid sequence.
365 --
366 -- This code adapts this elaborated interface back to the original TextEncoding
367 -- interface.
368 --
369 -- FIXME: it is possible that Handle code using the haDecoder/haEncoder fields
370 -- could be made clearer by using the 'encode' interface directly. I have not
371 -- looked into this.
372 --
373 -- FIXME: we should use recover to deal with EOF, rather than always throwing an
374 -- IOException (ioe_invalidCharacter).
375
376 streamEncode :: BufferCodec from to state
377 -> Buffer from -> Buffer to
378 -> IO (Buffer from, Buffer to)
379 streamEncode codec from to = go (from, to)
380 where
381 go (from, to) = do
382 (why, from', to') <- encode codec from to
383 -- When we are dealing with Handles, we don't care about input/output
384 -- underflow particularly, and we want to delay errors about invalid
385 -- sequences as far as possible.
386 case why of
387 Encoding.InvalidSequence | bufL from == bufL from' -> recover codec from' to' >>= go
388 _ -> return (from', to')
389
390 -- -----------------------------------------------------------------------------
391 -- Handle Finalizers
392
393 -- For a duplex handle, we arrange that the read side points to the write side
394 -- (and hence keeps it alive if the read side is alive). This is done by
395 -- having the haOtherSide field of the read side point to the read side.
396 -- The finalizer is then placed on the write side, and the handle only gets
397 -- finalized once, when both sides are no longer required.
398
399 -- NOTE about finalized handles: It's possible that a handle can be
400 -- finalized and then we try to use it later, for example if the
401 -- handle is referenced from another finalizer, or from a thread that
402 -- has become unreferenced and then resurrected (arguably in the
403 -- latter case we shouldn't finalize the Handle...). Anyway,
404 -- we try to emit a helpful message which is better than nothing.
405 --
406 -- [later; 8/2010] However, a program like this can yield a strange
407 -- error message:
408 --
409 -- main = writeFile "out" loop
410 -- loop = let x = x in x
411 --
412 -- because the main thread and the Handle are both unreachable at the
413 -- same time, the Handle may get finalized before the main thread
414 -- receives the NonTermination exception, and the exception handler
415 -- will then report an error. We'd rather this was not an error and
416 -- the program just prints "<<loop>>".
417
418 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
419 handleFinalizer fp m = do
420 handle_ <- takeMVar m
421 (handle_', _) <- hClose_help handle_
422 putMVar m handle_'
423 return ()
424
425 -- ---------------------------------------------------------------------------
426 -- Allocating buffers
427
428 -- using an 8k char buffer instead of 32k improved performance for a
429 -- basic "cat" program by ~30% for me. --SDM
430 dEFAULT_CHAR_BUFFER_SIZE :: Int
431 dEFAULT_CHAR_BUFFER_SIZE = 2048 -- 8k/sizeof(HsChar)
432
433 getCharBuffer :: IODevice dev => dev -> BufferState
434 -> IO (IORef CharBuffer, BufferMode)
435 getCharBuffer dev state = do
436 buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
437 ioref <- newIORef buffer
438 is_tty <- IODevice.isTerminal dev
439
440 let buffer_mode
441 | is_tty = LineBuffering
442 | otherwise = BlockBuffering Nothing
443
444 return (ioref, buffer_mode)
445
446 mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
447 mkUnBuffer state = do
448 buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
449 -- See [note Buffer Sizing], GHC.IO.Handle.Types
450 ref <- newIORef buffer
451 return (ref, NoBuffering)
452
453 -- -----------------------------------------------------------------------------
454 -- Flushing buffers
455
456 -- | syncs the file with the buffer, including moving the
457 -- file pointer backwards in the case of a read buffer. This can fail
458 -- on a non-seekable read Handle.
459 flushBuffer :: Handle__ -> IO ()
460 flushBuffer h_@Handle__{..} = do
461 buf <- readIORef haCharBuffer
462 case bufState buf of
463 ReadBuffer -> do
464 flushCharReadBuffer h_
465 flushByteReadBuffer h_
466 WriteBuffer -> do
467 flushByteWriteBuffer h_
468
469 -- | flushes the Char buffer only. Works on all Handles.
470 flushCharBuffer :: Handle__ -> IO ()
471 flushCharBuffer h_@Handle__{..} = do
472 cbuf <- readIORef haCharBuffer
473 case bufState cbuf of
474 ReadBuffer -> do
475 flushCharReadBuffer h_
476 WriteBuffer ->
477 when (not (isEmptyBuffer cbuf)) $
478 error "internal IO library error: Char buffer non-empty"
479
480 -- -----------------------------------------------------------------------------
481 -- Writing data (flushing write buffers)
482
483 -- flushWriteBuffer flushes the buffer iff it contains pending write
484 -- data. Flushes both the Char and the byte buffer, leaving both
485 -- empty.
486 flushWriteBuffer :: Handle__ -> IO ()
487 flushWriteBuffer h_@Handle__{..} = do
488 buf <- readIORef haByteBuffer
489 when (isWriteBuffer buf) $ flushByteWriteBuffer h_
490
491 flushByteWriteBuffer :: Handle__ -> IO ()
492 flushByteWriteBuffer h_@Handle__{..} = do
493 bbuf <- readIORef haByteBuffer
494 when (not (isEmptyBuffer bbuf)) $ do
495 bbuf' <- Buffered.flushWriteBuffer haDevice bbuf
496 writeIORef haByteBuffer bbuf'
497
498 -- write the contents of the CharBuffer to the Handle__.
499 -- The data will be encoded and pushed to the byte buffer,
500 -- flushing if the buffer becomes full.
501 writeCharBuffer :: Handle__ -> CharBuffer -> IO ()
502 writeCharBuffer h_@Handle__{..} !cbuf = do
503 --
504 bbuf <- readIORef haByteBuffer
505
506 debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++
507 " bbuf=" ++ summaryBuffer bbuf)
508
509 (cbuf',bbuf') <- case haEncoder of
510 Nothing -> latin1_encode cbuf bbuf
511 Just encoder -> (streamEncode encoder) cbuf bbuf
512
513 debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++
514 " bbuf=" ++ summaryBuffer bbuf')
515
516 -- flush if the write buffer is full
517 if isFullBuffer bbuf'
518 -- or we made no progress
519 || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf
520 -- or the byte buffer has more elements than the user wanted buffered
521 || (case haBufferMode of
522 BlockBuffering (Just s) -> bufferElems bbuf' >= s
523 NoBuffering -> True
524 _other -> False)
525 then do
526 bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'
527 writeIORef haByteBuffer bbuf''
528 else
529 writeIORef haByteBuffer bbuf'
530
531 if not (isEmptyBuffer cbuf')
532 then writeCharBuffer h_ cbuf'
533 else return ()
534
535 -- -----------------------------------------------------------------------------
536 -- Flushing read buffers
537
538 -- It is always possible to flush the Char buffer back to the byte buffer.
539 flushCharReadBuffer :: Handle__ -> IO ()
540 flushCharReadBuffer Handle__{..} = do
541 cbuf <- readIORef haCharBuffer
542 if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do
543
544 -- haLastDecode is the byte buffer just before we did our last batch of
545 -- decoding. We're going to re-decode the bytes up to the current char,
546 -- to find out where we should revert the byte buffer to.
547 (codec_state, bbuf0) <- readIORef haLastDecode
548
549 cbuf0 <- readIORef haCharBuffer
550 writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }
551
552 -- if we haven't used any characters from the char buffer, then just
553 -- re-install the old byte buffer.
554 if bufL cbuf0 == 0
555 then do writeIORef haByteBuffer bbuf0
556 return ()
557 else do
558
559 case haDecoder of
560 Nothing -> do
561 writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }
562 -- no decoder: the number of bytes to decode is the same as the
563 -- number of chars we have used up.
564
565 Just decoder -> do
566 debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
567 " cbuf=" ++ summaryBuffer cbuf0)
568
569 -- restore the codec state
570 setState decoder codec_state
571
572 (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0
573 cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
574
575 debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
576 " cbuf=" ++ summaryBuffer cbuf1)
577
578 writeIORef haByteBuffer bbuf1
579
580
581 -- When flushing the byte read buffer, we seek backwards by the number
582 -- of characters in the buffer. The file descriptor must therefore be
583 -- seekable: attempting to flush the read buffer on an unseekable
584 -- handle is not allowed.
585
586 flushByteReadBuffer :: Handle__ -> IO ()
587 flushByteReadBuffer h_@Handle__{..} = do
588 bbuf <- readIORef haByteBuffer
589
590 if isEmptyBuffer bbuf then return () else do
591
592 seekable <- IODevice.isSeekable haDevice
593 when (not seekable) $ ioe_cannotFlushNotSeekable
594
595 let seek = negate (bufR bbuf - bufL bbuf)
596
597 debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)
598 IODevice.seek haDevice RelativeSeek (fromIntegral seek)
599
600 writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 }
601
602 -- ----------------------------------------------------------------------------
603 -- Making Handles
604
605 mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
606 -> FilePath
607 -> HandleType
608 -> Bool -- buffered?
609 -> Maybe TextEncoding
610 -> NewlineMode
611 -> Maybe HandleFinalizer
612 -> Maybe (MVar Handle__)
613 -> IO Handle
614
615 mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
616 openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
617
618 let buf_state = initBufferState ha_type
619 bbuf <- Buffered.newBuffer dev buf_state
620 bbufref <- newIORef bbuf
621 last_decode <- newIORef (error "codec_state", bbuf)
622
623 (cbufref,bmode) <-
624 if buffered then getCharBuffer dev buf_state
625 else mkUnBuffer buf_state
626
627 spares <- newIORef BufferListNil
628 newFileHandle filepath finalizer
629 (Handle__ { haDevice = dev,
630 haType = ha_type,
631 haBufferMode = bmode,
632 haByteBuffer = bbufref,
633 haLastDecode = last_decode,
634 haCharBuffer = cbufref,
635 haBuffers = spares,
636 haEncoder = mb_encoder,
637 haDecoder = mb_decoder,
638 haCodec = mb_codec,
639 haInputNL = inputNL nl,
640 haOutputNL = outputNL nl,
641 haOtherSide = other_side
642 })
643
644 -- | makes a new 'Handle'
645 mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
646 => dev -- ^ the underlying IO device, which must support
647 -- 'IODevice', 'BufferedIO' and 'Typeable'
648 -> FilePath
649 -- ^ a string describing the 'Handle', e.g. the file
650 -- path for a file. Used in error messages.
651 -> IOMode
652 -- The mode in which the 'Handle' is to be used
653 -> Maybe TextEncoding
654 -- Create the 'Handle' with no text encoding?
655 -> NewlineMode
656 -- Translate newlines?
657 -> IO Handle
658 mkFileHandle dev filepath iomode mb_codec tr_newlines = do
659 mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
660 tr_newlines
661 (Just handleFinalizer) Nothing{-other_side-}
662
663 -- | like 'mkFileHandle', except that a 'Handle' is created with two
664 -- independent buffers, one for reading and one for writing. Used for
665 -- full-duplex streams, such as network sockets.
666 mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
667 -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
668 mkDuplexHandle dev filepath mb_codec tr_newlines = do
669
670 write_side@(FileHandle _ write_m) <-
671 mkHandle dev filepath WriteHandle True mb_codec
672 tr_newlines
673 (Just handleFinalizer)
674 Nothing -- no othersie
675
676 read_side@(FileHandle _ read_m) <-
677 mkHandle dev filepath ReadHandle True mb_codec
678 tr_newlines
679 Nothing -- no finalizer
680 (Just write_m)
681
682 return (DuplexHandle filepath read_m write_m)
683
684 ioModeToHandleType :: IOMode -> HandleType
685 ioModeToHandleType ReadMode = ReadHandle
686 ioModeToHandleType WriteMode = WriteHandle
687 ioModeToHandleType ReadWriteMode = ReadWriteHandle
688 ioModeToHandleType AppendMode = AppendHandle
689
690 initBufferState :: HandleType -> BufferState
691 initBufferState ReadHandle = ReadBuffer
692 initBufferState _ = WriteBuffer
693
694 openTextEncoding
695 :: Maybe TextEncoding
696 -> HandleType
697 -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
698 -> IO a
699
700 openTextEncoding Nothing ha_type cont = cont Nothing Nothing
701 openTextEncoding (Just TextEncoding{..}) ha_type cont = do
702 mb_decoder <- if isReadableHandleType ha_type then do
703 decoder <- mkTextDecoder
704 return (Just decoder)
705 else
706 return Nothing
707 mb_encoder <- if isWritableHandleType ha_type then do
708 encoder <- mkTextEncoder
709 return (Just encoder)
710 else
711 return Nothing
712 cont mb_encoder mb_decoder
713
714 closeTextCodecs :: Handle__ -> IO ()
715 closeTextCodecs Handle__{..} = do
716 case haDecoder of Nothing -> return (); Just d -> Encoding.close d
717 case haEncoder of Nothing -> return (); Just d -> Encoding.close d
718
719 -- ---------------------------------------------------------------------------
720 -- closing Handles
721
722 -- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
723 -- EOF is read or an IO error occurs on a lazy stream. The
724 -- semi-closed Handle is then closed immediately. We have to be
725 -- careful with DuplexHandles though: we have to leave the closing to
726 -- the finalizer in that case, because the write side may still be in
727 -- use.
728 hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
729 hClose_help handle_ =
730 case haType handle_ of
731 ClosedHandle -> return (handle_,Nothing)
732 _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible
733 -- it is important that hClose doesn't fail and
734 -- leave the Handle open (#3128), so we catch
735 -- exceptions when flushing the buffer.
736 (h_, mb_exc2) <- hClose_handle_ handle_
737 return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)
738
739
740 trymaybe :: IO () -> IO (Maybe SomeException)
741 trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
742
743 hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
744 hClose_handle_ h_@Handle__{..} = do
745
746 -- close the file descriptor, but not when this is the read
747 -- side of a duplex handle.
748 -- If an exception is raised by the close(), we want to continue
749 -- to close the handle and release the lock if it has one, then
750 -- we return the exception to the caller of hClose_help which can
751 -- raise it if necessary.
752 maybe_exception <-
753 case haOtherSide of
754 Nothing -> trymaybe $ IODevice.close haDevice
755 Just _ -> return Nothing
756
757 -- free the spare buffers
758 writeIORef haBuffers BufferListNil
759 writeIORef haCharBuffer noCharBuffer
760 writeIORef haByteBuffer noByteBuffer
761
762 -- release our encoder/decoder
763 closeTextCodecs h_
764
765 -- we must set the fd to -1, because the finalizer is going
766 -- to run eventually and try to close/unlock it.
767 -- ToDo: necessary? the handle will be marked ClosedHandle
768 -- XXX GHC won't let us use record update here, hence wildcards
769 return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)
770
771 {-# NOINLINE noCharBuffer #-}
772 noCharBuffer :: CharBuffer
773 noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer
774
775 {-# NOINLINE noByteBuffer #-}
776 noByteBuffer :: Buffer Word8
777 noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer
778
779 -- ---------------------------------------------------------------------------
780 -- Looking ahead
781
782 hLookAhead_ :: Handle__ -> IO Char
783 hLookAhead_ handle_@Handle__{..} = do
784 buf <- readIORef haCharBuffer
785
786 -- fill up the read buffer if necessary
787 new_buf <- if isEmptyBuffer buf
788 then readTextDevice handle_ buf
789 else return buf
790 writeIORef haCharBuffer new_buf
791
792 peekCharBuf (bufRaw buf) (bufL buf)
793
794 -- ---------------------------------------------------------------------------
795 -- debugging
796
797 debugIO :: String -> IO ()
798 debugIO s
799 | c_DEBUG_DUMP
800 = do _ <- withCStringLen (s ++ "\n") $
801 \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
802 return ()
803 | otherwise = return ()
804
805 -- ----------------------------------------------------------------------------
806 -- Text input/output
807
808 -- Read characters into the provided buffer. Return when any
809 -- characters are available; raise an exception if the end of
810 -- file is reached.
811 readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
812 readTextDevice h_@Handle__{..} cbuf = do
813 --
814 bbuf0 <- readIORef haByteBuffer
815
816 debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
817 " bbuf=" ++ summaryBuffer bbuf0)
818
819 bbuf1 <- if not (isEmptyBuffer bbuf0)
820 then return bbuf0
821 else do
822 (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
823 if r == 0 then ioe_EOF else do -- raise EOF
824 return bbuf1
825
826 debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
827
828 (bbuf2,cbuf') <-
829 case haDecoder of
830 Nothing -> do
831 writeIORef haLastDecode (error "codec_state", bbuf1)
832 latin1_decode bbuf1 cbuf
833 Just decoder -> do
834 state <- getState decoder
835 writeIORef haLastDecode (state, bbuf1)
836 (streamEncode decoder) bbuf1 cbuf
837
838 debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
839 " bbuf=" ++ summaryBuffer bbuf2)
840
841 writeIORef haByteBuffer bbuf2
842 if bufR cbuf' == bufR cbuf -- no new characters
843 then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char
844 else return cbuf'
845
846 -- we have an incomplete byte sequence at the end of the buffer: try to
847 -- read more bytes.
848 readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
849 readTextDevice' h_@Handle__{..} bbuf0 cbuf = do
850 --
851 -- copy the partial sequence to the beginning of the buffer, so we have
852 -- room to read more bytes.
853 bbuf1 <- slideContents bbuf0
854
855 bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
856 if r == 0
857 then ioe_invalidCharacter
858 else return bbuf2
859
860 debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)
861
862 (bbuf3,cbuf') <-
863 case haDecoder of
864 Nothing -> do
865 writeIORef haLastDecode (error "codec_state", bbuf2)
866 latin1_decode bbuf2 cbuf
867 Just decoder -> do
868 state <- getState decoder
869 writeIORef haLastDecode (state, bbuf2)
870 (streamEncode decoder) bbuf2 cbuf
871
872 debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf' ++
873 " bbuf=" ++ summaryBuffer bbuf3)
874
875 writeIORef haByteBuffer bbuf3
876 if bufR cbuf == bufR cbuf'
877 then readTextDevice' h_ bbuf3 cbuf'
878 else return cbuf'
879
880 -- Read characters into the provided buffer. Do not block;
881 -- return zero characters instead. Raises an exception on end-of-file.
882 readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
883 readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
884 --
885 bbuf0 <- readIORef haByteBuffer
886 when (isEmptyBuffer bbuf0) $ do
887 (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
888 if isNothing r then ioe_EOF else do -- raise EOF
889 writeIORef haByteBuffer bbuf1
890
891 decodeByteBuf h_ cbuf
892
893 -- Decode bytes from the byte buffer into the supplied CharBuffer.
894 decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer
895 decodeByteBuf h_@Handle__{..} cbuf = do
896 --
897 bbuf0 <- readIORef haByteBuffer
898
899 (bbuf2,cbuf') <-
900 case haDecoder of
901 Nothing -> do
902 writeIORef haLastDecode (error "codec_state", bbuf0)
903 latin1_decode bbuf0 cbuf
904 Just decoder -> do
905 state <- getState decoder
906 writeIORef haLastDecode (state, bbuf0)
907 (streamEncode decoder) bbuf0 cbuf
908
909 writeIORef haByteBuffer bbuf2
910 return cbuf'