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