1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
6 -----------------------------------------------------------------------------
9 -- Copyright : (c) The University of Glasgow, 1994-2001
10 -- License : see libraries/base/LICENSE
12 -- Maintainer : libraries@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable
16 -- This module defines the basic operations on I\/O \"handles\".
18 -----------------------------------------------------------------------------
21 withHandle, withHandle', withHandle_,
22 wantWritableHandle, wantReadableHandle, wantSeekableHandle,
24 newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
25 flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
26 fillReadBuffer, fillReadBufferWithoutBlocking,
27 readRawBuffer, readRawBufferPtr,
28 writeRawBuffer, writeRawBufferPtr,
30 #ifndef mingw32_TARGET_OS
34 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
36 stdin, stdout, stderr,
37 IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
38 hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
39 hFlush, hDuplicate, hDuplicateTo,
43 HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
44 SeekMode(..), hSeek, hTell,
46 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
47 hSetEcho, hGetEcho, hIsTerminalDevice,
57 #include "ghcconfig.h"
64 import System.IO.Error
65 import System.Posix.Internals
71 import GHC.Read ( Read )
76 import GHC.Num ( Integer(..), Num(..) )
78 import GHC.Real ( toInteger )
82 -- -----------------------------------------------------------------------------
85 -- hWaitForInput blocks (should use a timeout)
87 -- unbuffered hGetLine is a bit dodgy
89 -- hSetBuffering: can't change buffering on a stream,
90 -- when the read buffer is non-empty? (no way to flush the buffer)
92 -- ---------------------------------------------------------------------------
93 -- Are files opened by default in text or binary mode, if the user doesn't
96 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
98 -- ---------------------------------------------------------------------------
99 -- Creating a new handle
101 newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
102 newFileHandle filepath finalizer hc = do
104 addMVarFinalizer m (finalizer m)
105 return (FileHandle filepath m)
107 -- ---------------------------------------------------------------------------
108 -- Working with Handles
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.
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.
121 There are three versions of @withHandle@: corresponding to the three
122 possible combinations of:
124 - the operation may side-effect the handle
125 - the operation may return a result
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 ].
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
137 withHandle' :: String -> Handle -> MVar Handle__
138 -> (Handle__ -> IO (Handle__,a)) -> IO a
139 withHandle' fun h m act =
142 checkBufferInvariants h_
143 (h',v) <- catchException (act h_)
144 (\ err -> putMVar m h_ >>
146 IOException ex -> ioError (augmentIOError ex fun h)
148 checkBufferInvariants h'
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
157 withHandle_' fun h m act =
160 checkBufferInvariants h_
161 v <- catchException (act h_)
162 (\ err -> putMVar m h_ >>
164 IOException ex -> ioError (augmentIOError ex fun h)
166 checkBufferInvariants h_
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
176 withHandle__' fun h m act =
179 checkBufferInvariants h_
180 h' <- catchException (act h_)
181 (\ err -> putMVar m h_ >>
183 IOException ex -> ioError (augmentIOError ex fun h)
185 checkBufferInvariants h'
189 augmentIOError (IOError _ iot _ str fp) fun h
190 = IOError (Just h) iot fun str filepath
193 | otherwise = case h of
194 FileHandle fp _ -> Just fp
195 DuplexHandle fp _ _ -> Just fp
197 -- ---------------------------------------------------------------------------
198 -- Wrapper for write operations.
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
208 :: String -> Handle -> MVar Handle__
209 -> (Handle__ -> IO a) -> IO a
210 wantWritableHandle' fun h m act
211 = withHandle_' fun h m (checkWritableHandle act)
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_
222 if not (bufferIsWritable buf)
223 then do b <- flushReadBuffer (haFD handle_) buf
224 return b{ bufState=WriteBuffer }
226 writeIORef ref new_buf
228 _other -> act handle_
230 -- ---------------------------------------------------------------------------
231 -- Wrapper for read operations.
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
241 :: String -> Handle -> MVar Handle__
242 -> (Handle__ -> IO a) -> IO a
243 wantReadableHandle' fun h m act
244 = withHandle_' fun h m (checkReadableHandle act)
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_
255 when (bufferIsWritable buf) $ do
256 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
257 writeIORef ref new_buf{ bufState=ReadBuffer }
259 _other -> act handle_
261 -- ---------------------------------------------------------------------------
262 -- Wrapper for seek operations.
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)
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
279 -- -----------------------------------------------------------------------------
282 ioe_closedHandle, ioe_EOF,
283 ioe_notReadable, ioe_notWritable,
284 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
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"
305 ioe_finalizedHandle fp = throw (IOException
306 (IOError Nothing IllegalOperation ""
307 "handle is finalized" (Just fp)))
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.
315 -- -----------------------------------------------------------------------------
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.
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.
331 stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
332 stdHandleFinalizer fp m = do
334 flushWriteBufferOnly h_
335 putMVar m (ioe_finalizedHandle fp)
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_
347 putMVar m (ioe_finalizedHandle fp)
349 -- ---------------------------------------------------------------------------
350 -- Grimy buffer operations
353 checkBufferInvariants h_ = do
354 let ref = haBuffer h_
355 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
360 && ( r /= w || (r == 0 && w == 0) )
361 && ( state /= WriteBuffer || r == 0 )
362 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
364 then error "buffer invariant violation"
367 checkBufferInvariants h_ = return ()
370 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
371 newEmptyBuffer b state size
372 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
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 #) ->
383 case newByteArray# size s of { (# s, b #) ->
385 (# s, newEmptyBuffer b state sz #) }
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#) #)
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#)) #)
397 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
398 getBuffer fd state = do
399 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
400 ioref <- newIORef buffer
404 | is_tty = LineBuffering
405 | otherwise = BlockBuffering Nothing
407 return (ioref, buffer_mode)
409 mkUnBuffer :: IO (IORef Buffer)
411 buffer <- allocateBuffer 1 ReadBuffer
414 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
415 flushWriteBufferOnly :: Handle__ -> IO ()
416 flushWriteBufferOnly h_ = do
420 new_buf <- if bufferIsWritable buf
421 then flushWriteBuffer fd (haIsStream h_) buf
423 writeIORef ref new_buf
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 ()
429 let ref = haBuffer h_
434 ReadBuffer -> flushReadBuffer (haFD h_) buf
435 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
437 writeIORef ref flushed_buf
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.
444 flushReadBuffer :: FD -> Buffer -> IO Buffer
445 flushReadBuffer fd buf
446 | bufferEmpty buf = return buf
448 let off = negate (bufWPtr buf - bufRPtr buf)
450 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
452 throwErrnoIfMinus1Retry "flushReadBuffer"
453 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
454 return buf{ bufWPtr=0, bufRPtr=0 }
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
461 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
464 then return (buf{ bufRPtr=0, bufWPtr=0 })
466 res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
467 (fromIntegral r) (fromIntegral bytes)
468 let res' = fromIntegral res
470 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
471 else return buf{ bufRPtr=0, bufWPtr=0 }
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
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.
486 fillReadBufferLoop fd is_line is_stream buf b w size = do
488 if bytes == 0 -- buffer full?
489 then return buf{ bufRPtr=0, bufWPtr=w }
492 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
494 res <- readRawBuffer "fillReadBuffer" fd is_stream b
495 (fromIntegral w) (fromIntegral bytes)
496 let res' = fromIntegral res
498 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
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' }
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
515 puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
517 res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
518 0 (fromIntegral size)
519 let res' = fromIntegral res
521 puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
523 return buf{ bufRPtr=0, bufWPtr=res' }
525 -- Low level routines for reading/writing to (raw)buffers:
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))
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)
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))
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))
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))
558 foreign import ccall unsafe "__hscore_PrelHandle_read"
559 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
561 foreign import ccall unsafe "__hscore_PrelHandle_read"
562 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
564 foreign import ccall unsafe "__hscore_PrelHandle_write"
565 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
567 foreign import ccall unsafe "__hscore_PrelHandle_write"
568 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
570 #else /* mingw32_TARGET_OS.... */
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
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
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
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
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
596 -- Async versions of the read/write primitives, for the non-threaded RTS
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
603 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
604 else return (fromIntegral l)
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)
611 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
612 else return (fromIntegral l)
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
619 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
620 else return (fromIntegral l)
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)
627 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
628 else return (fromIntegral l)
630 -- Blocking versions of the read/write primitives, for the threaded RTS
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
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
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
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
660 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
661 -- These calls may block, but that's ok.
663 foreign import ccall safe "__hscore_PrelHandle_read"
664 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
666 foreign import ccall safe "__hscore_PrelHandle_read"
667 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
669 foreign import ccall safe "__hscore_PrelHandle_write"
670 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
672 foreign import ccall safe "__hscore_PrelHandle_write"
673 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
675 foreign import ccall safe "__hscore_PrelHandle_recv"
676 recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
678 foreign import ccall safe "__hscore_PrelHandle_recv"
679 recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
681 foreign import ccall safe "__hscore_PrelHandle_send"
682 send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
684 foreign import ccall safe "__hscore_PrelHandle_send"
685 send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
687 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
690 -- ---------------------------------------------------------------------------
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.
702 -- | A handle managing input from the Haskell program's standard input channel.
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
710 -- | A handle managing output to the Haskell program's standard output channel.
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
720 -- | A handle managing output to the Haskell program's standard error channel.
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
728 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
730 -- ---------------------------------------------------------------------------
731 -- Opening and Closing Files
733 addFilePathToIOError fun fp (IOError h iot _ str _)
734 = IOError h iot fun str (Just fp)
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'.
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.
752 -- This operation may fail with:
754 -- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
756 -- * 'isDoesNotExistError' if the file does not exist; or
758 -- * 'isPermissionError' if the user does not have permission to open the file.
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
765 (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
766 (\e -> ioError (addFilePathToIOError "openFile" fp e))
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'.)
777 openBinaryFile :: FilePath -> IOMode -> IO Handle
778 openBinaryFile fp m =
780 (openFile' fp m True)
781 (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
783 openFile' filepath mode binary =
784 withCString filepath $ \ f ->
787 oflags1 = case mode of
788 ReadMode -> read_flags
789 WriteMode -> write_flags
790 ReadWriteMode -> rw_flags
791 AppendMode -> append_flags
797 oflags = oflags1 .|. binary_flags
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)
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
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).
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
825 -- ---------------------------------------------------------------------------
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
833 let (ha_type, write) =
835 ReadMode -> ( ReadHandle, False )
836 WriteMode -> ( WriteHandle, True )
837 ReadWriteMode -> ( ReadWriteHandle, True )
838 AppendMode -> ( AppendHandle, True )
840 -- open() won't tell us if it was a directory if we only opened for
841 -- reading, so check again.
849 ioException (IOError Nothing InappropriateType "openFile"
850 "is a directory" Nothing)
853 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
854 | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
856 -- regular files need to be locked
858 #ifndef mingw32_TARGET_OS
859 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
861 ioException (IOError Nothing ResourceBusy "openFile"
862 "file is locked" Nothing)
864 mkFileHandle fd is_socket filepath ha_type binary
867 fdToHandle :: FD -> IO Handle
870 let fd_str = "<file descriptor: " ++ show fd ++ ">"
871 openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
874 #ifndef mingw32_TARGET_OS
875 foreign import ccall unsafe "lockFile"
876 lockFile :: CInt -> CInt -> CInt -> IO CInt
878 foreign import ccall unsafe "unlockFile"
879 unlockFile :: CInt -> IO CInt
882 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
884 mkStdHandle fd filepath ha_type buf bmode = do
885 spares <- newIORef BufferListNil
886 newFileHandle filepath (stdHandleFinalizer filepath)
887 (Handle__ { haFD = fd,
889 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
891 haBufferMode = bmode,
894 haOtherSide = Nothing
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,
905 haIsStream = is_stream,
906 haBufferMode = bmode,
909 haOtherSide = Nothing
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
917 Handle__ { haFD = fd,
918 haType = WriteHandle,
920 haIsStream = is_stream,
921 haBufferMode = w_bmode,
923 haBuffers = w_spares,
924 haOtherSide = Nothing
926 write_side <- newMVar w_handle_
928 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
929 r_spares <- newIORef BufferListNil
931 Handle__ { haFD = fd,
934 haIsStream = is_stream,
935 haBufferMode = r_bmode,
937 haBuffers = r_spares,
938 haOtherSide = Just write_side
940 read_side <- newMVar r_handle_
942 addMVarFinalizer write_side (handleFinalizer filepath write_side)
943 return (DuplexHandle filepath read_side write_side)
946 initBufferState ReadHandle = ReadBuffer
947 initBufferState _ = WriteBuffer
949 -- ---------------------------------------------------------------------------
952 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
953 -- computation finishes, if @hdl@ is writable its buffer is flushed as
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
961 hClose :: Handle -> IO ()
962 hClose h@(FileHandle _ m) = hClose' h m
963 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
965 hClose' h m = withHandle__' "hClose" h m $ hClose_help
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_
979 hClose_handle_ handle_ = do
980 let fd = haFD handle_
981 c_fd = fromIntegral fd
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
986 case haOtherSide handle_ of
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)
997 -- free the spare buffers
998 writeIORef (haBuffers handle_) BufferListNil
1000 #ifndef mingw32_TARGET_OS
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
1011 -----------------------------------------------------------------------------
1012 -- Detecting and changing the size of a file
1014 -- | For a handle @hdl@ which attached to a physical file,
1015 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1017 hFileSize :: Handle -> IO Integer
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_)
1027 else ioException (IOError Nothing InappropriateType "hFileSize"
1028 "not a regular file" Nothing)
1031 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
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))
1044 -- ---------------------------------------------------------------------------
1045 -- Detecting the End of Input
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'.
1052 hIsEOF :: Handle -> IO Bool
1055 (do hLookAhead handle; return False)
1056 (\e -> if isEOFError e then return True else ioError e)
1058 -- | The computation 'isEOF' is identical to 'hIsEOF',
1059 -- except that it works only on 'stdin'.
1062 isEOF = hIsEOF stdin
1064 -- ---------------------------------------------------------------------------
1067 -- | Computation 'hLookAhead' returns the next character from the handle
1068 -- without removing it from the input buffer, blocking until a character
1071 -- This operation may fail with:
1073 -- * 'isEOFError' if the end of file has been reached.
1075 hLookAhead :: Handle -> IO Char
1076 hLookAhead handle = do
1077 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
1078 let ref = haBuffer handle_
1080 is_line = haBufferMode handle_ == LineBuffering
1081 buf <- readIORef ref
1083 -- fill up the read buffer if necessary
1084 new_buf <- if bufferEmpty buf
1085 then fillReadBuffer fd is_line (haIsStream handle_) buf
1088 writeIORef ref new_buf
1090 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1093 -- ---------------------------------------------------------------------------
1094 -- Buffering Operations
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.
1100 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1101 -- handle @hdl@ on subsequent reads and writes.
1103 -- If the buffer mode is changed from 'BlockBuffering' or
1104 -- 'LineBuffering' to 'NoBuffering', then
1106 -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1108 -- * if @hdl@ is not writable, the contents of the buffer is discarded.
1110 -- This operation may fail with:
1112 -- * 'isPermissionError' if the handle has already been used for reading
1113 -- or writing and the implementation does not allow the buffering mode
1116 hSetBuffering :: Handle -> BufferMode -> IO ()
1117 hSetBuffering handle mode =
1118 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1119 case haType handle_ of
1120 ClosedHandle -> ioe_closedHandle
1123 - we flush the old buffer regardless of whether
1124 the new buffer could fit the contents of the old buffer
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]
1134 let state = initBufferState (haType handle_)
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
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_)) $
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
1157 _ -> setCooked (haFD handle_) True
1159 -- throw away spare buffers, they might be the wrong size
1160 writeIORef (haBuffers handle_) BufferListNil
1162 return (handle_{ haBufferMode = mode })
1164 -- -----------------------------------------------------------------------------
1167 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1168 -- in handle @hdl@ to be sent immediately to the operating system.
1170 -- This operation may fail with:
1172 -- * 'isFullError' if the device is full;
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.
1178 hFlush :: Handle -> IO ()
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
1188 -- -----------------------------------------------------------------------------
1189 -- Repositioning Handles
1191 data HandlePosn = HandlePosn Handle HandlePosition
1193 instance Eq HandlePosn where
1194 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1196 instance Show HandlePosn where
1197 showsPrec p (HandlePosn h pos) =
1198 showsPrec p h . showString " at position " . shows pos
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
1206 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1207 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1209 hGetPosn :: Handle -> IO HandlePosn
1210 hGetPosn handle = do
1211 posn <- hTell handle
1212 return (HandlePosn handle posn)
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'.
1218 -- This operation may fail with:
1220 -- * 'isPermissionError' if a system resource limit would be exceeded.
1222 hSetPosn :: HandlePosn -> IO ()
1223 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1225 -- ---------------------------------------------------------------------------
1228 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
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)
1238 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1239 seeking at or past EOF.
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
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.
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.
1260 -- This operation may fail with:
1262 -- * 'isPermissionError' if a system resource limit would be exceeded.
1264 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1265 hSeek handle mode offset =
1266 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1268 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1270 let ref = haBuffer handle_
1271 buf <- readIORef ref
1277 throwErrnoIfMinus1Retry_ "hSeek"
1278 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1281 whence = case mode of
1282 AbsoluteSeek -> sEEK_SET
1283 RelativeSeek -> sEEK_CUR
1284 SeekFromEnd -> sEEK_END
1286 if bufferIsWritable buf
1287 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1288 writeIORef ref new_buf
1292 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1293 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1296 new_buf <- flushReadBuffer (haFD handle_) buf
1297 writeIORef ref new_buf
1301 hTell :: Handle -> IO Integer
1303 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
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.
1311 let fd = fromIntegral (haFD handle_)
1312 posn <- fromIntegral `liftM`
1313 throwErrnoIfMinus1Retry "hGetPosn"
1314 (c_lseek fd 0 sEEK_CUR)
1316 let ref = haBuffer handle_
1317 buf <- readIORef ref
1320 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1321 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1323 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1324 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1328 -- -----------------------------------------------------------------------------
1329 -- Handle Properties
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.
1335 hIsOpen :: Handle -> IO Bool
1337 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1338 case haType handle_ of
1339 ClosedHandle -> return False
1340 SemiClosedHandle -> return False
1343 hIsClosed :: Handle -> IO Bool
1345 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1346 case haType handle_ of
1347 ClosedHandle -> return True
1350 {- not defined, nor exported, but mentioned
1351 here for documentation purposes:
1353 hSemiClosed :: Handle -> IO Bool
1357 return (not (ho || hc))
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)
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)
1378 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1381 hGetBuffering :: Handle -> IO BufferMode
1382 hGetBuffering handle =
1383 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1384 case haType handle_ of
1385 ClosedHandle -> ioe_closedHandle
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..
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
1401 || tEXT_MODE_SEEK_ALLOWED))
1403 -- -----------------------------------------------------------------------------
1404 -- Changing echo status (Non-standard GHC extensions)
1406 -- | Set the echoing status of a handle connected to a terminal.
1408 hSetEcho :: Handle -> Bool -> IO ()
1409 hSetEcho handle on = do
1410 isT <- hIsTerminalDevice handle
1414 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1415 case haType handle_ of
1416 ClosedHandle -> ioe_closedHandle
1417 _ -> setEcho (haFD handle_) on
1419 -- | Get the echoing status of a handle connected to a terminal.
1421 hGetEcho :: Handle -> IO Bool
1422 hGetEcho handle = do
1423 isT <- hIsTerminalDevice handle
1427 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1428 case haType handle_ of
1429 ClosedHandle -> ioe_closedHandle
1430 _ -> getEcho (haFD handle_)
1432 -- | Is the handle connected to a terminal?
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_)
1441 -- -----------------------------------------------------------------------------
1444 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1445 -- (See also 'openBinaryFile'.)
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}
1454 foreign import ccall unsafe "__hscore_setmode"
1455 setmode :: CInt -> Bool -> IO CInt
1457 -- -----------------------------------------------------------------------------
1458 -- Duplicating a Handle
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.
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)
1476 dupHandle_ other_side h_ = do
1477 -- flush the buffer first, so we don't have to copy its contents
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
1484 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1486 haBuffers = ioref_buffers,
1487 haOtherSide = other_side }
1488 return (h_, new_handle_)
1490 -- -----------------------------------------------------------------------------
1491 -- Replacing a Handle
1494 Makes the second handle a duplicate of the first handle. The second
1495 handle will be closed first, if it is not already.
1497 This can be used to retarget the standard Handles, for example:
1499 > do h <- openFile "mystdout" WriteMode
1500 > hDuplicateTo h stdout
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))
1516 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1517 "handles are incompatible" Nothing)
1519 -- ---------------------------------------------------------------------------
1522 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1523 -- than the (pure) instance of 'Show' for 'Handle'.
1525 hShow :: Handle -> IO String
1526 hShow h@(FileHandle path _) = showHandle' path False h
1527 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1529 showHandle' filepath is_duplex h =
1530 withHandle_ "showHandle" h $ \hdl_ ->
1532 showType | is_duplex = showString "duplex (read-write)"
1533 | otherwise = shows (haType hdl_)
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 "}" )
1545 showHdl :: HandleType -> ShowS -> ShowS
1548 ClosedHandle -> shows ht . showString "}"
1551 showBufMode :: Buffer -> BufferMode -> ShowS
1552 showBufMode buf bmo =
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)
1562 -- ---------------------------------------------------------------------------
1566 puts :: String -> IO ()
1567 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1571 -- -----------------------------------------------------------------------------
1574 throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
1575 throwErrnoIfMinus1RetryOnBlock loc f on_block =
1578 if (res :: CInt) == -1
1582 then throwErrnoIfMinus1RetryOnBlock loc f on_block
1583 else if err == eWOULDBLOCK || err == eAGAIN
1588 -- -----------------------------------------------------------------------------
1589 -- wrappers to platform-specific constants:
1591 foreign import ccall unsafe "__hscore_supportsTextMode"
1592 tEXT_MODE_SEEK_ALLOWED :: Bool
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