[project @ 2005-01-05 21:30:05 by krasimir]
[packages/base.git] / GHC / Handle.hs
1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
2
3 #undef DEBUG_DUMP
4 #undef DEBUG
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : GHC.Handle
9 -- Copyright : (c) The University of Glasgow, 1994-2001
10 -- License : see libraries/base/LICENSE
11 --
12 -- Maintainer : libraries@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable
15 --
16 -- This module defines the basic operations on I\/O \"handles\".
17 --
18 -----------------------------------------------------------------------------
19
20 module GHC.Handle (
21 withHandle, withHandle', withHandle_,
22 wantWritableHandle, wantReadableHandle, wantSeekableHandle,
23
24 newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
25 flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
26 fillReadBuffer, fillReadBufferWithoutBlocking,
27 readRawBuffer, readRawBufferPtr,
28 writeRawBuffer, writeRawBufferPtr,
29
30 #ifndef mingw32_TARGET_OS
31 unlockFile,
32 #endif
33
34 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
35
36 stdin, stdout, stderr,
37 IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
38 hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
39 hFlush, hDuplicate, hDuplicateTo,
40
41 hClose, hClose_help,
42
43 HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
44 SeekMode(..), hSeek, hTell,
45
46 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
47 hSetEcho, hGetEcho, hIsTerminalDevice,
48
49 hShow,
50
51 #ifdef DEBUG_DUMP
52 puts,
53 #endif
54
55 ) where
56
57 #include "ghcconfig.h"
58
59 import Control.Monad
60 import Data.Bits
61 import Data.Maybe
62 import Foreign
63 import Foreign.C
64 import System.IO.Error
65 import System.Posix.Internals
66
67 import GHC.Real
68
69 import GHC.Arr
70 import GHC.Base
71 import GHC.Read ( Read )
72 import GHC.List
73 import GHC.IOBase
74 import GHC.Exception
75 import GHC.Enum
76 import GHC.Num ( Integer(..), Num(..) )
77 import GHC.Show
78 import GHC.Real ( toInteger )
79
80 import GHC.Conc
81
82 -- -----------------------------------------------------------------------------
83 -- TODO:
84
85 -- hWaitForInput blocks (should use a timeout)
86
87 -- unbuffered hGetLine is a bit dodgy
88
89 -- hSetBuffering: can't change buffering on a stream,
90 -- when the read buffer is non-empty? (no way to flush the buffer)
91
92 -- ---------------------------------------------------------------------------
93 -- Are files opened by default in text or binary mode, if the user doesn't
94 -- specify?
95
96 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
97
98 -- ---------------------------------------------------------------------------
99 -- Creating a new handle
100
101 newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
102 newFileHandle filepath finalizer hc = do
103 m <- newMVar hc
104 addMVarFinalizer m (finalizer m)
105 return (FileHandle filepath m)
106
107 -- ---------------------------------------------------------------------------
108 -- Working with Handles
109
110 {-
111 In the concurrent world, handles are locked during use. This is done
112 by wrapping an MVar around the handle which acts as a mutex over
113 operations on the handle.
114
115 To avoid races, we use the following bracketing operations. The idea
116 is to obtain the lock, do some operation and replace the lock again,
117 whether the operation succeeded or failed. We also want to handle the
118 case where the thread receives an exception while processing the IO
119 operation: in these cases we also want to relinquish the lock.
120
121 There are three versions of @withHandle@: corresponding to the three
122 possible combinations of:
123
124 - the operation may side-effect the handle
125 - the operation may return a result
126
127 If the operation generates an error or an exception is raised, the
128 original handle is always replaced [ this is the case at the moment,
129 but we might want to revisit this in the future --SDM ].
130 -}
131
132 {-# INLINE withHandle #-}
133 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
134 withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
135 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
136
137 withHandle' :: String -> Handle -> MVar Handle__
138 -> (Handle__ -> IO (Handle__,a)) -> IO a
139 withHandle' fun h m act =
140 block $ do
141 h_ <- takeMVar m
142 checkBufferInvariants h_
143 (h',v) <- catchException (act h_)
144 (\ err -> putMVar m h_ >>
145 case err of
146 IOException ex -> ioError (augmentIOError ex fun h)
147 _ -> throw err)
148 checkBufferInvariants h'
149 putMVar m h'
150 return v
151
152 {-# INLINE withHandle_ #-}
153 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
154 withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
155 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
156
157 withHandle_' fun h m act =
158 block $ do
159 h_ <- takeMVar m
160 checkBufferInvariants h_
161 v <- catchException (act h_)
162 (\ err -> putMVar m h_ >>
163 case err of
164 IOException ex -> ioError (augmentIOError ex fun h)
165 _ -> throw err)
166 checkBufferInvariants h_
167 putMVar m h_
168 return v
169
170 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
171 withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
172 withAllHandles__ fun h@(DuplexHandle _ r w) act = do
173 withHandle__' fun h r act
174 withHandle__' fun h w act
175
176 withHandle__' fun h m act =
177 block $ do
178 h_ <- takeMVar m
179 checkBufferInvariants h_
180 h' <- catchException (act h_)
181 (\ err -> putMVar m h_ >>
182 case err of
183 IOException ex -> ioError (augmentIOError ex fun h)
184 _ -> throw err)
185 checkBufferInvariants h'
186 putMVar m h'
187 return ()
188
189 augmentIOError (IOError _ iot _ str fp) fun h
190 = IOError (Just h) iot fun str filepath
191 where filepath
192 | Just _ <- fp = fp
193 | otherwise = case h of
194 FileHandle fp _ -> Just fp
195 DuplexHandle fp _ _ -> Just fp
196
197 -- ---------------------------------------------------------------------------
198 -- Wrapper for write operations.
199
200 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
201 wantWritableHandle fun h@(FileHandle _ m) act
202 = wantWritableHandle' fun h m act
203 wantWritableHandle fun h@(DuplexHandle _ _ m) act
204 = wantWritableHandle' fun h m act
205 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
206
207 wantWritableHandle'
208 :: String -> Handle -> MVar Handle__
209 -> (Handle__ -> IO a) -> IO a
210 wantWritableHandle' fun h m act
211 = withHandle_' fun h m (checkWritableHandle act)
212
213 checkWritableHandle act handle_
214 = case haType handle_ of
215 ClosedHandle -> ioe_closedHandle
216 SemiClosedHandle -> ioe_closedHandle
217 ReadHandle -> ioe_notWritable
218 ReadWriteHandle -> do
219 let ref = haBuffer handle_
220 buf <- readIORef ref
221 new_buf <-
222 if not (bufferIsWritable buf)
223 then do b <- flushReadBuffer (haFD handle_) buf
224 return b{ bufState=WriteBuffer }
225 else return buf
226 writeIORef ref new_buf
227 act handle_
228 _other -> act handle_
229
230 -- ---------------------------------------------------------------------------
231 -- Wrapper for read operations.
232
233 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
234 wantReadableHandle fun h@(FileHandle _ m) act
235 = wantReadableHandle' fun h m act
236 wantReadableHandle fun h@(DuplexHandle _ m _) act
237 = wantReadableHandle' fun h m act
238 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
239
240 wantReadableHandle'
241 :: String -> Handle -> MVar Handle__
242 -> (Handle__ -> IO a) -> IO a
243 wantReadableHandle' fun h m act
244 = withHandle_' fun h m (checkReadableHandle act)
245
246 checkReadableHandle act handle_ =
247 case haType handle_ of
248 ClosedHandle -> ioe_closedHandle
249 SemiClosedHandle -> ioe_closedHandle
250 AppendHandle -> ioe_notReadable
251 WriteHandle -> ioe_notReadable
252 ReadWriteHandle -> do
253 let ref = haBuffer handle_
254 buf <- readIORef ref
255 when (bufferIsWritable buf) $ do
256 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
257 writeIORef ref new_buf{ bufState=ReadBuffer }
258 act handle_
259 _other -> act handle_
260
261 -- ---------------------------------------------------------------------------
262 -- Wrapper for seek operations.
263
264 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
265 wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
266 ioException (IOError (Just h) IllegalOperation fun
267 "handle is not seekable" Nothing)
268 wantSeekableHandle fun h@(FileHandle _ m) act =
269 withHandle_' fun h m (checkSeekableHandle act)
270
271 checkSeekableHandle act handle_ =
272 case haType handle_ of
273 ClosedHandle -> ioe_closedHandle
274 SemiClosedHandle -> ioe_closedHandle
275 AppendHandle -> ioe_notSeekable
276 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
277 | otherwise -> ioe_notSeekable_notBin
278
279 -- -----------------------------------------------------------------------------
280 -- Handy IOErrors
281
282 ioe_closedHandle, ioe_EOF,
283 ioe_notReadable, ioe_notWritable,
284 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
285
286 ioe_closedHandle = ioException
287 (IOError Nothing IllegalOperation ""
288 "handle is closed" Nothing)
289 ioe_EOF = ioException
290 (IOError Nothing EOF "" "" Nothing)
291 ioe_notReadable = ioException
292 (IOError Nothing IllegalOperation ""
293 "handle is not open for reading" Nothing)
294 ioe_notWritable = ioException
295 (IOError Nothing IllegalOperation ""
296 "handle is not open for writing" Nothing)
297 ioe_notSeekable = ioException
298 (IOError Nothing IllegalOperation ""
299 "handle is not seekable" Nothing)
300 ioe_notSeekable_notBin = ioException
301 (IOError Nothing IllegalOperation ""
302 "seek operations on text-mode handles are not allowed on this platform"
303 Nothing)
304
305 ioe_finalizedHandle fp = throw (IOException
306 (IOError Nothing IllegalOperation ""
307 "handle is finalized" (Just fp)))
308
309 ioe_bufsiz :: Int -> IO a
310 ioe_bufsiz n = ioException
311 (IOError Nothing InvalidArgument "hSetBuffering"
312 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
313 -- 9 => should be parens'ified.
314
315 -- -----------------------------------------------------------------------------
316 -- Handle Finalizers
317
318 -- For a duplex handle, we arrange that the read side points to the write side
319 -- (and hence keeps it alive if the read side is alive). This is done by
320 -- having the haOtherSide field of the read side point to the read side.
321 -- The finalizer is then placed on the write side, and the handle only gets
322 -- finalized once, when both sides are no longer required.
323
324 -- NOTE about finalized handles: It's possible that a handle can be
325 -- finalized and then we try to use it later, for example if the
326 -- handle is referenced from another finalizer, or from a thread that
327 -- has become unreferenced and then resurrected (arguably in the
328 -- latter case we shouldn't finalize the Handle...). Anyway,
329 -- we try to emit a helpful message which is better than nothing.
330
331 stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
332 stdHandleFinalizer fp m = do
333 h_ <- takeMVar m
334 flushWriteBufferOnly h_
335 putMVar m (ioe_finalizedHandle fp)
336
337 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
338 handleFinalizer fp m = do
339 handle_ <- takeMVar m
340 case haType handle_ of
341 ClosedHandle -> return ()
342 _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
343 -- ignore errors and async exceptions, and close the
344 -- descriptor anyway...
345 hClose_handle_ handle_
346 return ()
347 putMVar m (ioe_finalizedHandle fp)
348
349 -- ---------------------------------------------------------------------------
350 -- Grimy buffer operations
351
352 #ifdef DEBUG
353 checkBufferInvariants h_ = do
354 let ref = haBuffer h_
355 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
356 if not (
357 size > 0
358 && r <= w
359 && w <= size
360 && ( r /= w || (r == 0 && w == 0) )
361 && ( state /= WriteBuffer || r == 0 )
362 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
363 )
364 then error "buffer invariant violation"
365 else return ()
366 #else
367 checkBufferInvariants h_ = return ()
368 #endif
369
370 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
371 newEmptyBuffer b state size
372 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
373
374 allocateBuffer :: Int -> BufferState -> IO Buffer
375 allocateBuffer sz@(I# size) state = IO $ \s ->
376 #ifdef mingw32_TARGET_OS
377 -- To implement asynchronous I/O under Win32, we have to pass
378 -- buffer references to external threads that handles the
379 -- filling/emptying of their contents. Hence, the buffer cannot
380 -- be moved around by the GC.
381 case newPinnedByteArray# size s of { (# s, b #) ->
382 #else
383 case newByteArray# size s of { (# s, b #) ->
384 #endif
385 (# s, newEmptyBuffer b state sz #) }
386
387 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
388 writeCharIntoBuffer slab (I# off) (C# c)
389 = IO $ \s -> case writeCharArray# slab off c s of
390 s -> (# s, I# (off +# 1#) #)
391
392 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
393 readCharFromBuffer slab (I# off)
394 = IO $ \s -> case readCharArray# slab off s of
395 (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
396
397 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
398 getBuffer fd state = do
399 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
400 ioref <- newIORef buffer
401 is_tty <- fdIsTTY fd
402
403 let buffer_mode
404 | is_tty = LineBuffering
405 | otherwise = BlockBuffering Nothing
406
407 return (ioref, buffer_mode)
408
409 mkUnBuffer :: IO (IORef Buffer)
410 mkUnBuffer = do
411 buffer <- allocateBuffer 1 ReadBuffer
412 newIORef buffer
413
414 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
415 flushWriteBufferOnly :: Handle__ -> IO ()
416 flushWriteBufferOnly h_ = do
417 let fd = haFD h_
418 ref = haBuffer h_
419 buf <- readIORef ref
420 new_buf <- if bufferIsWritable buf
421 then flushWriteBuffer fd (haIsStream h_) buf
422 else return buf
423 writeIORef ref new_buf
424
425 -- flushBuffer syncs the file with the buffer, including moving the
426 -- file pointer backwards in the case of a read buffer.
427 flushBuffer :: Handle__ -> IO ()
428 flushBuffer h_ = do
429 let ref = haBuffer h_
430 buf <- readIORef ref
431
432 flushed_buf <-
433 case bufState buf of
434 ReadBuffer -> flushReadBuffer (haFD h_) buf
435 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
436
437 writeIORef ref flushed_buf
438
439 -- When flushing a read buffer, we seek backwards by the number of
440 -- characters in the buffer. The file descriptor must therefore be
441 -- seekable: attempting to flush the read buffer on an unseekable
442 -- handle is not allowed.
443
444 flushReadBuffer :: FD -> Buffer -> IO Buffer
445 flushReadBuffer fd buf
446 | bufferEmpty buf = return buf
447 | otherwise = do
448 let off = negate (bufWPtr buf - bufRPtr buf)
449 # ifdef DEBUG_DUMP
450 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
451 # endif
452 throwErrnoIfMinus1Retry "flushReadBuffer"
453 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
454 return buf{ bufWPtr=0, bufRPtr=0 }
455
456 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
457 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
458 seq fd $ do -- strictness hack
459 let bytes = w - r
460 #ifdef DEBUG_DUMP
461 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
462 #endif
463 if bytes == 0
464 then return (buf{ bufRPtr=0, bufWPtr=0 })
465 else do
466 res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
467 (fromIntegral r) (fromIntegral bytes)
468 let res' = fromIntegral res
469 if res' < bytes
470 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
471 else return buf{ bufRPtr=0, bufWPtr=0 }
472
473 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
474 fillReadBuffer fd is_line is_stream
475 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
476 -- buffer better be empty:
477 assert (r == 0 && w == 0) $ do
478 fillReadBufferLoop fd is_line is_stream buf b w size
479
480 -- For a line buffer, we just get the first chunk of data to arrive,
481 -- and don't wait for the whole buffer to be full (but we *do* wait
482 -- until some data arrives). This isn't really line buffering, but it
483 -- appears to be what GHC has done for a long time, and I suspect it
484 -- is more useful than line buffering in most cases.
485
486 fillReadBufferLoop fd is_line is_stream buf b w size = do
487 let bytes = size - w
488 if bytes == 0 -- buffer full?
489 then return buf{ bufRPtr=0, bufWPtr=w }
490 else do
491 #ifdef DEBUG_DUMP
492 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
493 #endif
494 res <- readRawBuffer "fillReadBuffer" fd is_stream b
495 (fromIntegral w) (fromIntegral bytes)
496 let res' = fromIntegral res
497 #ifdef DEBUG_DUMP
498 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
499 #endif
500 if res' == 0
501 then if w == 0
502 then ioe_EOF
503 else return buf{ bufRPtr=0, bufWPtr=w }
504 else if res' < bytes && not is_line
505 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
506 else return buf{ bufRPtr=0, bufWPtr=w+res' }
507
508
509 fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
510 fillReadBufferWithoutBlocking fd is_stream
511 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
512 -- buffer better be empty:
513 assert (r == 0 && w == 0) $ do
514 #ifdef DEBUG_DUMP
515 puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
516 #endif
517 res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
518 0 (fromIntegral size)
519 let res' = fromIntegral res
520 #ifdef DEBUG_DUMP
521 puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
522 #endif
523 return buf{ bufRPtr=0, bufWPtr=res' }
524
525 -- Low level routines for reading/writing to (raw)buffers:
526
527 #ifndef mingw32_TARGET_OS
528 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
529 readRawBuffer loc fd is_stream buf off len =
530 throwErrnoIfMinus1RetryMayBlock loc
531 (read_rawBuffer fd buf off len)
532 (threadWaitRead (fromIntegral fd))
533
534 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
535 readRawBufferNoBlock loc fd is_stream buf off len =
536 throwErrnoIfMinus1RetryOnBlock loc
537 (read_rawBuffer fd buf off len)
538 (return 0)
539
540 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
541 readRawBufferPtr loc fd is_stream buf off len =
542 throwErrnoIfMinus1RetryMayBlock loc
543 (read_off fd buf off len)
544 (threadWaitRead (fromIntegral fd))
545
546 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
547 writeRawBuffer loc fd is_stream buf off len =
548 throwErrnoIfMinus1RetryMayBlock loc
549 (write_rawBuffer (fromIntegral fd) buf off len)
550 (threadWaitWrite (fromIntegral fd))
551
552 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
553 writeRawBufferPtr loc fd is_stream buf off len =
554 throwErrnoIfMinus1RetryMayBlock loc
555 (write_off (fromIntegral fd) buf off len)
556 (threadWaitWrite (fromIntegral fd))
557
558 foreign import ccall unsafe "__hscore_PrelHandle_read"
559 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
560
561 foreign import ccall unsafe "__hscore_PrelHandle_read"
562 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
563
564 foreign import ccall unsafe "__hscore_PrelHandle_write"
565 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
566
567 foreign import ccall unsafe "__hscore_PrelHandle_write"
568 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
569
570 #else /* mingw32_TARGET_OS.... */
571
572 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
573 readRawBuffer loc fd is_stream buf off len
574 | threaded = blockingReadRawBuffer loc fd is_stream buf off len
575 | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
576
577 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
578 readRawBufferPtr loc fd is_stream buf off len
579 | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
580 | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
581
582 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
583 writeRawBuffer loc fd is_stream buf off len
584 | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
585 | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
586
587 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
588 writeRawBufferPtr loc fd is_stream buf off len
589 | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
590 | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len
591
592 -- ToDo: we don't have a non-blocking primitve read on Win32
593 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
594 readRawBufferNoBlock = readRawBufferNoBlock
595
596 -- Async versions of the read/write primitives, for the non-threaded RTS
597
598 asyncReadRawBuffer loc fd is_stream buf off len = do
599 (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0)
600 (fromIntegral len) off buf
601 if l == (-1)
602 then
603 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
604 else return (fromIntegral l)
605
606 asyncReadRawBufferPtr loc fd is_stream buf off len = do
607 (l, rc) <- asyncRead fd (if is_stream then 1 else 0)
608 (fromIntegral len) (buf `plusPtr` off)
609 if l == (-1)
610 then
611 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
612 else return (fromIntegral l)
613
614 asyncWriteRawBuffer loc fd is_stream buf off len = do
615 (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0)
616 (fromIntegral len) off buf
617 if l == (-1)
618 then
619 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
620 else return (fromIntegral l)
621
622 asyncWriteRawBufferPtr loc fd is_stream buf off len = do
623 (l, rc) <- asyncWrite fd (if is_stream then 1 else 0)
624 (fromIntegral len) (buf `plusPtr` off)
625 if l == (-1)
626 then
627 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
628 else return (fromIntegral l)
629
630 -- Blocking versions of the read/write primitives, for the threaded RTS
631
632 blockingReadRawBuffer loc fd True buf off len =
633 throwErrnoIfMinus1Retry loc $
634 recv_rawBuffer fd buf off len
635 blockingReadRawBuffer loc fd False buf off len =
636 throwErrnoIfMinus1Retry loc $
637 read_rawBuffer fd buf off len
638
639 blockingReadRawBufferPtr loc fd True buf off len =
640 throwErrnoIfMinus1Retry loc $
641 recv_off fd buf off len
642 blockingReadRawBufferPtr loc fd False buf off len =
643 throwErrnoIfMinus1Retry loc $
644 read_off fd buf off len
645
646 blockingWriteRawBuffer loc fd True buf off len =
647 throwErrnoIfMinus1Retry loc $
648 send_rawBuffer (fromIntegral fd) buf off len
649 blockingWriteRawBuffer loc fd False buf off len =
650 throwErrnoIfMinus1Retry loc $
651 write_rawBuffer (fromIntegral fd) buf off len
652
653 blockingWriteRawBufferPtr loc fd True buf off len =
654 throwErrnoIfMinus1Retry loc $
655 send_off (fromIntegral fd) buf off len
656 blockingWriteRawBufferPtr loc fd False buf off len =
657 throwErrnoIfMinus1Retry loc $
658 write_off (fromIntegral fd) buf off len
659
660 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
661 -- These calls may block, but that's ok.
662
663 foreign import ccall safe "__hscore_PrelHandle_read"
664 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
665
666 foreign import ccall safe "__hscore_PrelHandle_read"
667 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
668
669 foreign import ccall safe "__hscore_PrelHandle_write"
670 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
671
672 foreign import ccall safe "__hscore_PrelHandle_write"
673 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
674
675 foreign import ccall safe "__hscore_PrelHandle_recv"
676 recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
677
678 foreign import ccall safe "__hscore_PrelHandle_recv"
679 recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
680
681 foreign import ccall safe "__hscore_PrelHandle_send"
682 send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
683
684 foreign import ccall safe "__hscore_PrelHandle_send"
685 send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
686
687 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
688 #endif
689
690 -- ---------------------------------------------------------------------------
691 -- Standard Handles
692
693 -- Three handles are allocated during program initialisation. The first
694 -- two manage input or output from the Haskell program's standard input
695 -- or output channel respectively. The third manages output to the
696 -- standard error channel. These handles are initially open.
697
698 fd_stdin = 0 :: FD
699 fd_stdout = 1 :: FD
700 fd_stderr = 2 :: FD
701
702 -- | A handle managing input from the Haskell program's standard input channel.
703 stdin :: Handle
704 stdin = unsafePerformIO $ do
705 -- ToDo: acquire lock
706 setNonBlockingFD fd_stdin
707 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
708 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
709
710 -- | A handle managing output to the Haskell program's standard output channel.
711 stdout :: Handle
712 stdout = unsafePerformIO $ do
713 -- ToDo: acquire lock
714 -- We don't set non-blocking mode on stdout or sterr, because
715 -- some shells don't recover properly.
716 -- setNonBlockingFD fd_stdout
717 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
718 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
719
720 -- | A handle managing output to the Haskell program's standard error channel.
721 stderr :: Handle
722 stderr = unsafePerformIO $ do
723 -- ToDo: acquire lock
724 -- We don't set non-blocking mode on stdout or sterr, because
725 -- some shells don't recover properly.
726 -- setNonBlockingFD fd_stderr
727 buf <- mkUnBuffer
728 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
729
730 -- ---------------------------------------------------------------------------
731 -- Opening and Closing Files
732
733 addFilePathToIOError fun fp (IOError h iot _ str _)
734 = IOError h iot fun str (Just fp)
735
736 -- | Computation 'openFile' @file mode@ allocates and returns a new, open
737 -- handle to manage the file @file@. It manages input if @mode@
738 -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
739 -- and both input and output if mode is 'ReadWriteMode'.
740 --
741 -- If the file does not exist and it is opened for output, it should be
742 -- created as a new file. If @mode@ is 'WriteMode' and the file
743 -- already exists, then it should be truncated to zero length.
744 -- Some operating systems delete empty files, so there is no guarantee
745 -- that the file will exist following an 'openFile' with @mode@
746 -- 'WriteMode' unless it is subsequently written to successfully.
747 -- The handle is positioned at the end of the file if @mode@ is
748 -- 'AppendMode', and otherwise at the beginning (in which case its
749 -- internal position is 0).
750 -- The initial buffer mode is implementation-dependent.
751 --
752 -- This operation may fail with:
753 --
754 -- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
755 --
756 -- * 'isDoesNotExistError' if the file does not exist; or
757 --
758 -- * 'isPermissionError' if the user does not have permission to open the file.
759 --
760 -- Note: if you will be working with files containing binary data, you'll want to
761 -- be using 'openBinaryFile'.
762 openFile :: FilePath -> IOMode -> IO Handle
763 openFile fp im =
764 catch
765 (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
766 (\e -> ioError (addFilePathToIOError "openFile" fp e))
767
768 -- | Like 'openFile', but open the file in binary mode.
769 -- On Windows, reading a file in text mode (which is the default)
770 -- will translate CRLF to LF, and writing will translate LF to CRLF.
771 -- This is usually what you want with text files. With binary files
772 -- this is undesirable; also, as usual under Microsoft operating systems,
773 -- text mode treats control-Z as EOF. Binary mode turns off all special
774 -- treatment of end-of-line and end-of-file characters.
775 -- (See also 'hSetBinaryMode'.)
776
777 openBinaryFile :: FilePath -> IOMode -> IO Handle
778 openBinaryFile fp m =
779 catch
780 (openFile' fp m True)
781 (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
782
783 openFile' filepath mode binary =
784 withCString filepath $ \ f ->
785
786 let
787 oflags1 = case mode of
788 ReadMode -> read_flags
789 WriteMode -> write_flags
790 ReadWriteMode -> rw_flags
791 AppendMode -> append_flags
792
793 binary_flags
794 | binary = o_BINARY
795 | otherwise = 0
796
797 oflags = oflags1 .|. binary_flags
798 in do
799
800 -- the old implementation had a complicated series of three opens,
801 -- which is perhaps because we have to be careful not to open
802 -- directories. However, the man pages I've read say that open()
803 -- always returns EISDIR if the file is a directory and was opened
804 -- for writing, so I think we're ok with a single open() here...
805 fd <- fromIntegral `liftM`
806 throwErrnoIfMinus1Retry "openFile"
807 (c_open f (fromIntegral oflags) 0o666)
808
809 openFd fd Nothing False filepath mode binary
810 `catchException` \e -> do c_close (fromIntegral fd); throw e
811 -- NB. don't forget to close the FD if openFd fails, otherwise
812 -- this FD leaks.
813 -- ASSERT: if we just created the file, then openFd won't fail
814 -- (so we don't need to worry about removing the newly created file
815 -- in the event of an error).
816
817
818 std_flags = o_NONBLOCK .|. o_NOCTTY
819 output_flags = std_flags .|. o_CREAT
820 read_flags = std_flags .|. o_RDONLY
821 write_flags = output_flags .|. o_WRONLY .|. o_TRUNC
822 rw_flags = output_flags .|. o_RDWR
823 append_flags = write_flags .|. o_APPEND
824
825 -- ---------------------------------------------------------------------------
826 -- openFd
827
828 openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
829 openFd fd mb_fd_type is_socket filepath mode binary = do
830 -- turn on non-blocking mode
831 setNonBlockingFD fd
832
833 let (ha_type, write) =
834 case mode of
835 ReadMode -> ( ReadHandle, False )
836 WriteMode -> ( WriteHandle, True )
837 ReadWriteMode -> ( ReadWriteHandle, True )
838 AppendMode -> ( AppendHandle, True )
839
840 -- open() won't tell us if it was a directory if we only opened for
841 -- reading, so check again.
842 fd_type <-
843 case mb_fd_type of
844 Just x -> return x
845 Nothing -> fdType fd
846
847 case fd_type of
848 Directory ->
849 ioException (IOError Nothing InappropriateType "openFile"
850 "is a directory" Nothing)
851
852 Stream
853 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
854 | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
855
856 -- regular files need to be locked
857 RegularFile -> do
858 #ifndef mingw32_TARGET_OS
859 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
860 when (r == -1) $
861 ioException (IOError Nothing ResourceBusy "openFile"
862 "file is locked" Nothing)
863 #endif
864 mkFileHandle fd is_socket filepath ha_type binary
865
866
867 fdToHandle :: FD -> IO Handle
868 fdToHandle fd = do
869 mode <- fdGetMode fd
870 let fd_str = "<file descriptor: " ++ show fd ++ ">"
871 openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
872
873
874 #ifndef mingw32_TARGET_OS
875 foreign import ccall unsafe "lockFile"
876 lockFile :: CInt -> CInt -> CInt -> IO CInt
877
878 foreign import ccall unsafe "unlockFile"
879 unlockFile :: CInt -> IO CInt
880 #endif
881
882 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
883 -> IO Handle
884 mkStdHandle fd filepath ha_type buf bmode = do
885 spares <- newIORef BufferListNil
886 newFileHandle filepath (stdHandleFinalizer filepath)
887 (Handle__ { haFD = fd,
888 haType = ha_type,
889 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
890 haIsStream = False,
891 haBufferMode = bmode,
892 haBuffer = buf,
893 haBuffers = spares,
894 haOtherSide = Nothing
895 })
896
897 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
898 mkFileHandle fd is_stream filepath ha_type binary = do
899 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
900 spares <- newIORef BufferListNil
901 newFileHandle filepath (handleFinalizer filepath)
902 (Handle__ { haFD = fd,
903 haType = ha_type,
904 haIsBin = binary,
905 haIsStream = is_stream,
906 haBufferMode = bmode,
907 haBuffer = buf,
908 haBuffers = spares,
909 haOtherSide = Nothing
910 })
911
912 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
913 mkDuplexHandle fd is_stream filepath binary = do
914 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
915 w_spares <- newIORef BufferListNil
916 let w_handle_ =
917 Handle__ { haFD = fd,
918 haType = WriteHandle,
919 haIsBin = binary,
920 haIsStream = is_stream,
921 haBufferMode = w_bmode,
922 haBuffer = w_buf,
923 haBuffers = w_spares,
924 haOtherSide = Nothing
925 }
926 write_side <- newMVar w_handle_
927
928 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
929 r_spares <- newIORef BufferListNil
930 let r_handle_ =
931 Handle__ { haFD = fd,
932 haType = ReadHandle,
933 haIsBin = binary,
934 haIsStream = is_stream,
935 haBufferMode = r_bmode,
936 haBuffer = r_buf,
937 haBuffers = r_spares,
938 haOtherSide = Just write_side
939 }
940 read_side <- newMVar r_handle_
941
942 addMVarFinalizer write_side (handleFinalizer filepath write_side)
943 return (DuplexHandle filepath read_side write_side)
944
945
946 initBufferState ReadHandle = ReadBuffer
947 initBufferState _ = WriteBuffer
948
949 -- ---------------------------------------------------------------------------
950 -- Closing a handle
951
952 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
953 -- computation finishes, if @hdl@ is writable its buffer is flushed as
954 -- for 'hFlush'.
955 -- Performing 'hClose' on a handle that has already been closed has no effect;
956 -- doing so not an error. All other operations on a closed handle will fail.
957 -- If 'hClose' fails for any reason, any further operations (apart from
958 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
959 -- closed.
960
961 hClose :: Handle -> IO ()
962 hClose h@(FileHandle _ m) = hClose' h m
963 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
964
965 hClose' h m = withHandle__' "hClose" h m $ hClose_help
966
967 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
968 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
969 -- then closed immediately. We have to be careful with DuplexHandles
970 -- though: we have to leave the closing to the finalizer in that case,
971 -- because the write side may still be in use.
972 hClose_help :: Handle__ -> IO Handle__
973 hClose_help handle_ =
974 case haType handle_ of
975 ClosedHandle -> return handle_
976 _ -> do flushWriteBufferOnly handle_ -- interruptible
977 hClose_handle_ handle_
978
979 hClose_handle_ handle_ = do
980 let fd = haFD handle_
981 c_fd = fromIntegral fd
982
983 -- close the file descriptor, but not when this is the read
984 -- side of a duplex handle, and not when this is one of the
985 -- std file handles.
986 case haOtherSide handle_ of
987 Nothing ->
988 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
989 throwErrnoIfMinus1Retry_ "hClose"
990 #ifdef mingw32_TARGET_OS
991 (closeFd (haIsStream handle_) c_fd)
992 #else
993 (c_close c_fd)
994 #endif
995 Just _ -> return ()
996
997 -- free the spare buffers
998 writeIORef (haBuffers handle_) BufferListNil
999
1000 #ifndef mingw32_TARGET_OS
1001 -- unlock it
1002 unlockFile c_fd
1003 #endif
1004
1005 -- we must set the fd to -1, because the finalizer is going
1006 -- to run eventually and try to close/unlock it.
1007 return (handle_{ haFD = -1,
1008 haType = ClosedHandle
1009 })
1010
1011 -----------------------------------------------------------------------------
1012 -- Detecting and changing the size of a file
1013
1014 -- | For a handle @hdl@ which attached to a physical file,
1015 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1016
1017 hFileSize :: Handle -> IO Integer
1018 hFileSize handle =
1019 withHandle_ "hFileSize" handle $ \ handle_ -> do
1020 case haType handle_ of
1021 ClosedHandle -> ioe_closedHandle
1022 SemiClosedHandle -> ioe_closedHandle
1023 _ -> do flushWriteBufferOnly handle_
1024 r <- fdFileSize (haFD handle_)
1025 if r /= -1
1026 then return r
1027 else ioException (IOError Nothing InappropriateType "hFileSize"
1028 "not a regular file" Nothing)
1029
1030
1031 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
1032
1033 hSetFileSize :: Handle -> Integer -> IO ()
1034 hSetFileSize handle size =
1035 withHandle_ "hSetFileSize" handle $ \ handle_ -> do
1036 case haType handle_ of
1037 ClosedHandle -> ioe_closedHandle
1038 SemiClosedHandle -> ioe_closedHandle
1039 _ -> do flushWriteBufferOnly handle_
1040 throwErrnoIf (/=0) "hSetFileSize"
1041 (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
1042 return ()
1043
1044 -- ---------------------------------------------------------------------------
1045 -- Detecting the End of Input
1046
1047 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1048 -- 'True' if no further input can be taken from @hdl@ or for a
1049 -- physical file, if the current I\/O position is equal to the length of
1050 -- the file. Otherwise, it returns 'False'.
1051
1052 hIsEOF :: Handle -> IO Bool
1053 hIsEOF handle =
1054 catch
1055 (do hLookAhead handle; return False)
1056 (\e -> if isEOFError e then return True else ioError e)
1057
1058 -- | The computation 'isEOF' is identical to 'hIsEOF',
1059 -- except that it works only on 'stdin'.
1060
1061 isEOF :: IO Bool
1062 isEOF = hIsEOF stdin
1063
1064 -- ---------------------------------------------------------------------------
1065 -- Looking ahead
1066
1067 -- | Computation 'hLookAhead' returns the next character from the handle
1068 -- without removing it from the input buffer, blocking until a character
1069 -- is available.
1070 --
1071 -- This operation may fail with:
1072 --
1073 -- * 'isEOFError' if the end of file has been reached.
1074
1075 hLookAhead :: Handle -> IO Char
1076 hLookAhead handle = do
1077 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
1078 let ref = haBuffer handle_
1079 fd = haFD handle_
1080 is_line = haBufferMode handle_ == LineBuffering
1081 buf <- readIORef ref
1082
1083 -- fill up the read buffer if necessary
1084 new_buf <- if bufferEmpty buf
1085 then fillReadBuffer fd is_line (haIsStream handle_) buf
1086 else return buf
1087
1088 writeIORef ref new_buf
1089
1090 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1091 return c
1092
1093 -- ---------------------------------------------------------------------------
1094 -- Buffering Operations
1095
1096 -- Three kinds of buffering are supported: line-buffering,
1097 -- block-buffering or no-buffering. See GHC.IOBase for definition and
1098 -- further explanation of what the type represent.
1099
1100 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1101 -- handle @hdl@ on subsequent reads and writes.
1102 --
1103 -- If the buffer mode is changed from 'BlockBuffering' or
1104 -- 'LineBuffering' to 'NoBuffering', then
1105 --
1106 -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1107 --
1108 -- * if @hdl@ is not writable, the contents of the buffer is discarded.
1109 --
1110 -- This operation may fail with:
1111 --
1112 -- * 'isPermissionError' if the handle has already been used for reading
1113 -- or writing and the implementation does not allow the buffering mode
1114 -- to be changed.
1115
1116 hSetBuffering :: Handle -> BufferMode -> IO ()
1117 hSetBuffering handle mode =
1118 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1119 case haType handle_ of
1120 ClosedHandle -> ioe_closedHandle
1121 _ -> do
1122 {- Note:
1123 - we flush the old buffer regardless of whether
1124 the new buffer could fit the contents of the old buffer
1125 or not.
1126 - allow a handle's buffering to change even if IO has
1127 occurred (ANSI C spec. does not allow this, nor did
1128 the previous implementation of IO.hSetBuffering).
1129 - a non-standard extension is to allow the buffering
1130 of semi-closed handles to change [sof 6/98]
1131 -}
1132 flushBuffer handle_
1133
1134 let state = initBufferState (haType handle_)
1135 new_buf <-
1136 case mode of
1137 -- we always have a 1-character read buffer for
1138 -- unbuffered handles: it's needed to
1139 -- support hLookAhead.
1140 NoBuffering -> allocateBuffer 1 ReadBuffer
1141 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
1142 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1143 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
1144 | otherwise -> allocateBuffer n state
1145 writeIORef (haBuffer handle_) new_buf
1146
1147 -- for input terminals we need to put the terminal into
1148 -- cooked or raw mode depending on the type of buffering.
1149 is_tty <- fdIsTTY (haFD handle_)
1150 when (is_tty && isReadableHandleType (haType handle_)) $
1151 case mode of
1152 #ifndef mingw32_TARGET_OS
1153 -- 'raw' mode under win32 is a bit too specialised (and troublesome
1154 -- for most common uses), so simply disable its use here.
1155 NoBuffering -> setCooked (haFD handle_) False
1156 #endif
1157 _ -> setCooked (haFD handle_) True
1158
1159 -- throw away spare buffers, they might be the wrong size
1160 writeIORef (haBuffers handle_) BufferListNil
1161
1162 return (handle_{ haBufferMode = mode })
1163
1164 -- -----------------------------------------------------------------------------
1165 -- hFlush
1166
1167 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1168 -- in handle @hdl@ to be sent immediately to the operating system.
1169 --
1170 -- This operation may fail with:
1171 --
1172 -- * 'isFullError' if the device is full;
1173 --
1174 -- * 'isPermissionError' if a system resource limit would be exceeded.
1175 -- It is unspecified whether the characters in the buffer are discarded
1176 -- or retained under these circumstances.
1177
1178 hFlush :: Handle -> IO ()
1179 hFlush handle =
1180 wantWritableHandle "hFlush" handle $ \ handle_ -> do
1181 buf <- readIORef (haBuffer handle_)
1182 if bufferIsWritable buf && not (bufferEmpty buf)
1183 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1184 writeIORef (haBuffer handle_) flushed_buf
1185 else return ()
1186
1187
1188 -- -----------------------------------------------------------------------------
1189 -- Repositioning Handles
1190
1191 data HandlePosn = HandlePosn Handle HandlePosition
1192
1193 instance Eq HandlePosn where
1194 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1195
1196 instance Show HandlePosn where
1197 showsPrec p (HandlePosn h pos) =
1198 showsPrec p h . showString " at position " . shows pos
1199
1200 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1201 -- We represent it as an Integer on the Haskell side, but
1202 -- cheat slightly in that hGetPosn calls upon a C helper
1203 -- that reports the position back via (merely) an Int.
1204 type HandlePosition = Integer
1205
1206 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1207 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1208
1209 hGetPosn :: Handle -> IO HandlePosn
1210 hGetPosn handle = do
1211 posn <- hTell handle
1212 return (HandlePosn handle posn)
1213
1214 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1215 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1216 -- to the position it held at the time of the call to 'hGetPosn'.
1217 --
1218 -- This operation may fail with:
1219 --
1220 -- * 'isPermissionError' if a system resource limit would be exceeded.
1221
1222 hSetPosn :: HandlePosn -> IO ()
1223 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1224
1225 -- ---------------------------------------------------------------------------
1226 -- hSeek
1227
1228 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1229 data SeekMode
1230 = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
1231 | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
1232 -- from the current position.
1233 | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
1234 -- from the end of the file.
1235 deriving (Eq, Ord, Ix, Enum, Read, Show)
1236
1237 {- Note:
1238 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1239 seeking at or past EOF.
1240
1241 - we possibly deviate from the report on the issue of seeking within
1242 the buffer and whether to flush it or not. The report isn't exactly
1243 clear here.
1244 -}
1245
1246 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1247 -- @hdl@ depending on @mode@.
1248 -- The offset @i@ is given in terms of 8-bit bytes.
1249 --
1250 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1251 -- in the current buffer will first cause any items in the output buffer to be
1252 -- written to the device, and then cause the input buffer to be discarded.
1253 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1254 -- subset of the possible positioning operations (for instance, it may only
1255 -- be possible to seek to the end of a tape, or to a positive offset from
1256 -- the beginning or current position).
1257 -- It is not possible to set a negative I\/O position, or for
1258 -- a physical file, an I\/O position beyond the current end-of-file.
1259 --
1260 -- This operation may fail with:
1261 --
1262 -- * 'isPermissionError' if a system resource limit would be exceeded.
1263
1264 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1265 hSeek handle mode offset =
1266 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1267 # ifdef DEBUG_DUMP
1268 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1269 # endif
1270 let ref = haBuffer handle_
1271 buf <- readIORef ref
1272 let r = bufRPtr buf
1273 w = bufWPtr buf
1274 fd = haFD handle_
1275
1276 let do_seek =
1277 throwErrnoIfMinus1Retry_ "hSeek"
1278 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1279
1280 whence :: CInt
1281 whence = case mode of
1282 AbsoluteSeek -> sEEK_SET
1283 RelativeSeek -> sEEK_CUR
1284 SeekFromEnd -> sEEK_END
1285
1286 if bufferIsWritable buf
1287 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1288 writeIORef ref new_buf
1289 do_seek
1290 else do
1291
1292 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1293 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1294 else do
1295
1296 new_buf <- flushReadBuffer (haFD handle_) buf
1297 writeIORef ref new_buf
1298 do_seek
1299
1300
1301 hTell :: Handle -> IO Integer
1302 hTell handle =
1303 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1304
1305 #if defined(mingw32_TARGET_OS)
1306 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1307 -- so we can't easily calculate the file position using the
1308 -- current buffer size. Just flush instead.
1309 flushBuffer handle_
1310 #endif
1311 let fd = fromIntegral (haFD handle_)
1312 posn <- fromIntegral `liftM`
1313 throwErrnoIfMinus1Retry "hGetPosn"
1314 (c_lseek fd 0 sEEK_CUR)
1315
1316 let ref = haBuffer handle_
1317 buf <- readIORef ref
1318
1319 let real_posn
1320 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1321 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1322 # ifdef DEBUG_DUMP
1323 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1324 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1325 # endif
1326 return real_posn
1327
1328 -- -----------------------------------------------------------------------------
1329 -- Handle Properties
1330
1331 -- A number of operations return information about the properties of a
1332 -- handle. Each of these operations returns `True' if the handle has
1333 -- the specified property, and `False' otherwise.
1334
1335 hIsOpen :: Handle -> IO Bool
1336 hIsOpen handle =
1337 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1338 case haType handle_ of
1339 ClosedHandle -> return False
1340 SemiClosedHandle -> return False
1341 _ -> return True
1342
1343 hIsClosed :: Handle -> IO Bool
1344 hIsClosed handle =
1345 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1346 case haType handle_ of
1347 ClosedHandle -> return True
1348 _ -> return False
1349
1350 {- not defined, nor exported, but mentioned
1351 here for documentation purposes:
1352
1353 hSemiClosed :: Handle -> IO Bool
1354 hSemiClosed h = do
1355 ho <- hIsOpen h
1356 hc <- hIsClosed h
1357 return (not (ho || hc))
1358 -}
1359
1360 hIsReadable :: Handle -> IO Bool
1361 hIsReadable (DuplexHandle _ _ _) = return True
1362 hIsReadable handle =
1363 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1364 case haType handle_ of
1365 ClosedHandle -> ioe_closedHandle
1366 SemiClosedHandle -> ioe_closedHandle
1367 htype -> return (isReadableHandleType htype)
1368
1369 hIsWritable :: Handle -> IO Bool
1370 hIsWritable (DuplexHandle _ _ _) = return True
1371 hIsWritable handle =
1372 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1373 case haType handle_ of
1374 ClosedHandle -> ioe_closedHandle
1375 SemiClosedHandle -> ioe_closedHandle
1376 htype -> return (isWritableHandleType htype)
1377
1378 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1379 -- for @hdl@.
1380
1381 hGetBuffering :: Handle -> IO BufferMode
1382 hGetBuffering handle =
1383 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1384 case haType handle_ of
1385 ClosedHandle -> ioe_closedHandle
1386 _ ->
1387 -- We're being non-standard here, and allow the buffering
1388 -- of a semi-closed handle to be queried. -- sof 6/98
1389 return (haBufferMode handle_) -- could be stricter..
1390
1391 hIsSeekable :: Handle -> IO Bool
1392 hIsSeekable handle =
1393 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1394 case haType handle_ of
1395 ClosedHandle -> ioe_closedHandle
1396 SemiClosedHandle -> ioe_closedHandle
1397 AppendHandle -> return False
1398 _ -> do t <- fdType (haFD handle_)
1399 return (t == RegularFile
1400 && (haIsBin handle_
1401 || tEXT_MODE_SEEK_ALLOWED))
1402
1403 -- -----------------------------------------------------------------------------
1404 -- Changing echo status (Non-standard GHC extensions)
1405
1406 -- | Set the echoing status of a handle connected to a terminal.
1407
1408 hSetEcho :: Handle -> Bool -> IO ()
1409 hSetEcho handle on = do
1410 isT <- hIsTerminalDevice handle
1411 if not isT
1412 then return ()
1413 else
1414 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1415 case haType handle_ of
1416 ClosedHandle -> ioe_closedHandle
1417 _ -> setEcho (haFD handle_) on
1418
1419 -- | Get the echoing status of a handle connected to a terminal.
1420
1421 hGetEcho :: Handle -> IO Bool
1422 hGetEcho handle = do
1423 isT <- hIsTerminalDevice handle
1424 if not isT
1425 then return False
1426 else
1427 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1428 case haType handle_ of
1429 ClosedHandle -> ioe_closedHandle
1430 _ -> getEcho (haFD handle_)
1431
1432 -- | Is the handle connected to a terminal?
1433
1434 hIsTerminalDevice :: Handle -> IO Bool
1435 hIsTerminalDevice handle = do
1436 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1437 case haType handle_ of
1438 ClosedHandle -> ioe_closedHandle
1439 _ -> fdIsTTY (haFD handle_)
1440
1441 -- -----------------------------------------------------------------------------
1442 -- hSetBinaryMode
1443
1444 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1445 -- (See also 'openBinaryFile'.)
1446
1447 hSetBinaryMode :: Handle -> Bool -> IO ()
1448 hSetBinaryMode handle bin =
1449 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1450 do throwErrnoIfMinus1_ "hSetBinaryMode"
1451 (setmode (fromIntegral (haFD handle_)) bin)
1452 return handle_{haIsBin=bin}
1453
1454 foreign import ccall unsafe "__hscore_setmode"
1455 setmode :: CInt -> Bool -> IO CInt
1456
1457 -- -----------------------------------------------------------------------------
1458 -- Duplicating a Handle
1459
1460 -- |Returns a duplicate of the original handle, with its own buffer
1461 -- and file pointer. The original handle's buffer is flushed, including
1462 -- discarding any input data, before the handle is duplicated.
1463
1464 hDuplicate :: Handle -> IO Handle
1465 hDuplicate h@(FileHandle path m) = do
1466 new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1467 newFileHandle path (handleFinalizer path) new_h_
1468 hDuplicate h@(DuplexHandle path r w) = do
1469 new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1470 new_w <- newMVar new_w_
1471 new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1472 new_r <- newMVar new_r_
1473 addMVarFinalizer new_w (handleFinalizer path new_w)
1474 return (DuplexHandle path new_r new_w)
1475
1476 dupHandle_ other_side h_ = do
1477 -- flush the buffer first, so we don't have to copy its contents
1478 flushBuffer h_
1479 new_fd <- c_dup (fromIntegral (haFD h_))
1480 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1481 ioref <- newIORef buffer
1482 ioref_buffers <- newIORef BufferListNil
1483
1484 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1485 haBuffer = ioref,
1486 haBuffers = ioref_buffers,
1487 haOtherSide = other_side }
1488 return (h_, new_handle_)
1489
1490 -- -----------------------------------------------------------------------------
1491 -- Replacing a Handle
1492
1493 {- |
1494 Makes the second handle a duplicate of the first handle. The second
1495 handle will be closed first, if it is not already.
1496
1497 This can be used to retarget the standard Handles, for example:
1498
1499 > do h <- openFile "mystdout" WriteMode
1500 > hDuplicateTo h stdout
1501 -}
1502
1503 hDuplicateTo :: Handle -> Handle -> IO ()
1504 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
1505 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1506 _ <- hClose_help h2_
1507 withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1508 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
1509 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1510 _ <- hClose_help w2_
1511 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1512 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1513 _ <- hClose_help r2_
1514 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1515 hDuplicateTo h1 _ =
1516 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1517 "handles are incompatible" Nothing)
1518
1519 -- ---------------------------------------------------------------------------
1520 -- showing Handles.
1521 --
1522 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1523 -- than the (pure) instance of 'Show' for 'Handle'.
1524
1525 hShow :: Handle -> IO String
1526 hShow h@(FileHandle path _) = showHandle' path False h
1527 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1528
1529 showHandle' filepath is_duplex h =
1530 withHandle_ "showHandle" h $ \hdl_ ->
1531 let
1532 showType | is_duplex = showString "duplex (read-write)"
1533 | otherwise = shows (haType hdl_)
1534 in
1535 return
1536 (( showChar '{' .
1537 showHdl (haType hdl_)
1538 (showString "loc=" . showString filepath . showChar ',' .
1539 showString "type=" . showType . showChar ',' .
1540 showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1541 showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1542 ) "")
1543 where
1544
1545 showHdl :: HandleType -> ShowS -> ShowS
1546 showHdl ht cont =
1547 case ht of
1548 ClosedHandle -> shows ht . showString "}"
1549 _ -> cont
1550
1551 showBufMode :: Buffer -> BufferMode -> ShowS
1552 showBufMode buf bmo =
1553 case bmo of
1554 NoBuffering -> showString "none"
1555 LineBuffering -> showString "line"
1556 BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1557 BlockBuffering Nothing -> showString "block " . showParen True (shows def)
1558 where
1559 def :: Int
1560 def = bufSize buf
1561
1562 -- ---------------------------------------------------------------------------
1563 -- debugging
1564
1565 #ifdef DEBUG_DUMP
1566 puts :: String -> IO ()
1567 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1568 return ()
1569 #endif
1570
1571 -- -----------------------------------------------------------------------------
1572 -- utils
1573
1574 throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
1575 throwErrnoIfMinus1RetryOnBlock loc f on_block =
1576 do
1577 res <- f
1578 if (res :: CInt) == -1
1579 then do
1580 err <- getErrno
1581 if err == eINTR
1582 then throwErrnoIfMinus1RetryOnBlock loc f on_block
1583 else if err == eWOULDBLOCK || err == eAGAIN
1584 then do on_block
1585 else throwErrno loc
1586 else return res
1587
1588 -- -----------------------------------------------------------------------------
1589 -- wrappers to platform-specific constants:
1590
1591 foreign import ccall unsafe "__hscore_supportsTextMode"
1592 tEXT_MODE_SEEK_ALLOWED :: Bool
1593
1594 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1595 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1596 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1597 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt