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,
31 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
33 stdin, stdout, stderr,
34 IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
35 hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
36 hFlush, hDuplicate, hDuplicateTo,
40 HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
41 SeekMode(..), hSeek, hTell,
43 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
44 hSetEcho, hGetEcho, hIsTerminalDevice,
54 #include "ghcconfig.h"
61 import System.IO.Error
62 import System.Posix.Internals
68 import GHC.Read ( Read )
73 import GHC.Num ( Integer(..), Num(..) )
75 import GHC.Real ( toInteger )
79 -- -----------------------------------------------------------------------------
82 -- hWaitForInput blocks (should use a timeout)
84 -- unbuffered hGetLine is a bit dodgy
86 -- hSetBuffering: can't change buffering on a stream,
87 -- when the read buffer is non-empty? (no way to flush the buffer)
89 -- ---------------------------------------------------------------------------
90 -- Are files opened by default in text or binary mode, if the user doesn't
93 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
95 -- ---------------------------------------------------------------------------
96 -- Creating a new handle
98 newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
99 newFileHandle filepath finalizer hc = do
101 addMVarFinalizer m (finalizer m)
102 return (FileHandle filepath m)
104 -- ---------------------------------------------------------------------------
105 -- Working with Handles
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.
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.
118 There are three versions of @withHandle@: corresponding to the three
119 possible combinations of:
121 - the operation may side-effect the handle
122 - the operation may return a result
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 ].
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
134 withHandle' :: String -> Handle -> MVar Handle__
135 -> (Handle__ -> IO (Handle__,a)) -> IO a
136 withHandle' fun h m act =
139 checkBufferInvariants h_
140 (h',v) <- catchException (act h_)
141 (\ err -> putMVar m h_ >>
143 IOException ex -> ioError (augmentIOError ex fun h)
145 checkBufferInvariants h'
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
154 withHandle_' fun h m act =
157 checkBufferInvariants h_
158 v <- catchException (act h_)
159 (\ err -> putMVar m h_ >>
161 IOException ex -> ioError (augmentIOError ex fun h)
163 checkBufferInvariants h_
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
173 withHandle__' fun h m act =
176 checkBufferInvariants h_
177 h' <- catchException (act h_)
178 (\ err -> putMVar m h_ >>
180 IOException ex -> ioError (augmentIOError ex fun h)
182 checkBufferInvariants h'
186 augmentIOError (IOError _ iot _ str fp) fun h
187 = IOError (Just h) iot fun str filepath
190 | otherwise = case h of
191 FileHandle fp _ -> Just fp
192 DuplexHandle fp _ _ -> Just fp
194 -- ---------------------------------------------------------------------------
195 -- Wrapper for write operations.
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
205 :: String -> Handle -> MVar Handle__
206 -> (Handle__ -> IO a) -> IO a
207 wantWritableHandle' fun h m act
208 = withHandle_' fun h m (checkWritableHandle act)
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_
219 if not (bufferIsWritable buf)
220 then do b <- flushReadBuffer (haFD handle_) buf
221 return b{ bufState=WriteBuffer }
223 writeIORef ref new_buf
225 _other -> act handle_
227 -- ---------------------------------------------------------------------------
228 -- Wrapper for read operations.
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
238 :: String -> Handle -> MVar Handle__
239 -> (Handle__ -> IO a) -> IO a
240 wantReadableHandle' fun h m act
241 = withHandle_' fun h m (checkReadableHandle act)
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_
252 when (bufferIsWritable buf) $ do
253 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
254 writeIORef ref new_buf{ bufState=ReadBuffer }
256 _other -> act handle_
258 -- ---------------------------------------------------------------------------
259 -- Wrapper for seek operations.
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)
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
276 -- -----------------------------------------------------------------------------
279 ioe_closedHandle, ioe_EOF,
280 ioe_notReadable, ioe_notWritable,
281 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
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"
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.
308 -- -----------------------------------------------------------------------------
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.
317 stdHandleFinalizer :: MVar Handle__ -> IO ()
318 stdHandleFinalizer m = do
320 flushWriteBufferOnly h_
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_
333 -- ---------------------------------------------------------------------------
334 -- Grimy buffer operations
337 checkBufferInvariants h_ = do
338 let ref = haBuffer h_
339 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
344 && ( r /= w || (r == 0 && w == 0) )
345 && ( state /= WriteBuffer || r == 0 )
346 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
348 then error "buffer invariant violation"
351 checkBufferInvariants h_ = return ()
354 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
355 newEmptyBuffer b state size
356 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
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 #) ->
367 case newByteArray# size s of { (# s, b #) ->
369 (# s, newEmptyBuffer b state sz #) }
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#) #)
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#)) #)
381 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
382 getBuffer fd state = do
383 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
384 ioref <- newIORef buffer
388 | is_tty = LineBuffering
389 | otherwise = BlockBuffering Nothing
391 return (ioref, buffer_mode)
393 mkUnBuffer :: IO (IORef Buffer)
395 buffer <- allocateBuffer 1 ReadBuffer
398 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
399 flushWriteBufferOnly :: Handle__ -> IO ()
400 flushWriteBufferOnly h_ = do
404 new_buf <- if bufferIsWritable buf
405 then flushWriteBuffer fd (haIsStream h_) buf
407 writeIORef ref new_buf
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 ()
413 let ref = haBuffer h_
418 ReadBuffer -> flushReadBuffer (haFD h_) buf
419 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
421 writeIORef ref flushed_buf
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.
428 flushReadBuffer :: FD -> Buffer -> IO Buffer
429 flushReadBuffer fd buf
430 | bufferEmpty buf = return buf
432 let off = negate (bufWPtr buf - bufRPtr buf)
434 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
436 throwErrnoIfMinus1Retry "flushReadBuffer"
437 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
438 return buf{ bufWPtr=0, bufRPtr=0 }
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
445 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
448 then return (buf{ bufRPtr=0, bufWPtr=0 })
450 res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
451 (fromIntegral r) (fromIntegral bytes)
452 let res' = fromIntegral res
454 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
455 else return buf{ bufRPtr=0, bufWPtr=0 }
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
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.
470 fillReadBufferLoop fd is_line is_stream buf b w size = do
472 if bytes == 0 -- buffer full?
473 then return buf{ bufRPtr=0, bufWPtr=w }
476 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
478 res <- readRawBuffer "fillReadBuffer" fd is_stream b
479 (fromIntegral w) (fromIntegral bytes)
480 let res' = fromIntegral res
482 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
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' }
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
499 puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
501 res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
502 0 (fromIntegral size)
503 let res' = fromIntegral res
505 puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
507 return buf{ bufRPtr=0, bufWPtr=res' }
509 -- Low level routines for reading/writing to (raw)buffers:
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)
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)
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)
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)
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)
542 foreign import ccall unsafe "__hscore_PrelHandle_read"
543 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
545 foreign import ccall unsafe "__hscore_PrelHandle_read"
546 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
548 foreign import ccall unsafe "__hscore_PrelHandle_write"
549 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
551 foreign import ccall unsafe "__hscore_PrelHandle_write"
552 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
554 #else /* mingw32_TARGET_OS.... */
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
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
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
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
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
580 -- Async versions of the read/write primitives, for the non-threaded RTS
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
587 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
588 else return (fromIntegral l)
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)
595 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
596 else return (fromIntegral l)
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
603 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
604 else return (fromIntegral l)
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)
611 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
612 else return (fromIntegral l)
614 -- Blocking versions of the read/write primitives, for the threaded RTS
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
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
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
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
644 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
645 -- These calls may block, but that's ok.
647 foreign import ccall safe "__hscore_PrelHandle_read"
648 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
650 foreign import ccall safe "__hscore_PrelHandle_read"
651 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
653 foreign import ccall safe "__hscore_PrelHandle_write"
654 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
656 foreign import ccall safe "__hscore_PrelHandle_write"
657 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
659 foreign import ccall safe "__hscore_PrelHandle_recv"
660 recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
662 foreign import ccall safe "__hscore_PrelHandle_recv"
663 recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
665 foreign import ccall safe "__hscore_PrelHandle_send"
666 send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
668 foreign import ccall safe "__hscore_PrelHandle_send"
669 send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
671 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
674 -- ---------------------------------------------------------------------------
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.
686 -- | A handle managing input from the Haskell program's standard input channel.
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
694 -- | A handle managing output to the Haskell program's standard output channel.
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
704 -- | A handle managing output to the Haskell program's standard error channel.
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
712 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
714 -- ---------------------------------------------------------------------------
715 -- Opening and Closing Files
717 addFilePathToIOError fun fp (IOError h iot _ str _)
718 = IOError h iot fun str (Just fp)
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'.
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.
736 -- This operation may fail with:
738 -- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
740 -- * 'isDoesNotExistError' if the file does not exist; or
742 -- * 'isPermissionError' if the user does not have permission to open the file.
744 -- Note: if you will be working with files containing binary data, you'll want to
745 -- be using 'openBinaryFile'.
746 openFile :: FilePath -> IOMode -> IO Handle
749 (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
750 (\e -> ioError (addFilePathToIOError "openFile" fp e))
752 -- | Like 'openFile', but open the file in binary mode.
753 -- On Windows, reading a file in text mode (which is the default)
754 -- will translate CRLF to LF, and writing will translate LF to CRLF.
755 -- This is usually what you want with text files. With binary files
756 -- this is undesirable; also, as usual under Microsoft operating systems,
757 -- text mode treats control-Z as EOF. Binary mode turns off all special
758 -- treatment of end-of-line and end-of-file characters.
759 -- (See also 'hSetBinaryMode'.)
761 openBinaryFile :: FilePath -> IOMode -> IO Handle
762 openBinaryFile fp m =
764 (openFile' fp m True)
765 (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
767 openFile' filepath mode binary =
768 withCString filepath $ \ f ->
771 oflags1 = case mode of
772 ReadMode -> read_flags
773 WriteMode -> write_flags
774 ReadWriteMode -> rw_flags
775 AppendMode -> append_flags
777 truncate | WriteMode <- mode = True
784 oflags = oflags1 .|. binary_flags
787 -- the old implementation had a complicated series of three opens,
788 -- which is perhaps because we have to be careful not to open
789 -- directories. However, the man pages I've read say that open()
790 -- always returns EISDIR if the file is a directory and was opened
791 -- for writing, so I think we're ok with a single open() here...
792 fd <- fromIntegral `liftM`
793 throwErrnoIfMinus1Retry "openFile"
794 (c_open f (fromIntegral oflags) 0o666)
796 openFd fd Nothing False filepath mode binary truncate
797 `catchException` \e -> do c_close (fromIntegral fd); throw e
798 -- NB. don't forget to close the FD if openFd fails, otherwise
800 -- ASSERT: if we just created the file, then openFd won't fail
801 -- (so we don't need to worry about removing the newly created file
802 -- in the event of an error).
805 std_flags = o_NONBLOCK .|. o_NOCTTY
806 output_flags = std_flags .|. o_CREAT
807 read_flags = std_flags .|. o_RDONLY
808 write_flags = output_flags .|. o_WRONLY
809 rw_flags = output_flags .|. o_RDWR
810 append_flags = write_flags .|. o_APPEND
812 -- ---------------------------------------------------------------------------
815 openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
816 openFd fd mb_fd_type is_socket filepath mode binary truncate = do
817 -- turn on non-blocking mode
820 let (ha_type, write) =
822 ReadMode -> ( ReadHandle, False )
823 WriteMode -> ( WriteHandle, True )
824 ReadWriteMode -> ( ReadWriteHandle, True )
825 AppendMode -> ( AppendHandle, True )
827 -- open() won't tell us if it was a directory if we only opened for
828 -- reading, so check again.
836 ioException (IOError Nothing InappropriateType "openFile"
837 "is a directory" Nothing)
840 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
841 | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
843 -- regular files need to be locked
845 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
847 ioException (IOError Nothing ResourceBusy "openFile"
848 "file is locked" Nothing)
850 -- truncate the file if necessary
851 when truncate (fileTruncate filepath)
853 mkFileHandle fd is_socket filepath ha_type binary
856 fdToHandle :: FD -> IO Handle
859 let fd_str = "<file descriptor: " ++ show fd ++ ">"
860 openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} False{-no truncate-}
862 foreign import ccall unsafe "lockFile"
863 lockFile :: CInt -> CInt -> CInt -> IO CInt
865 foreign import ccall unsafe "unlockFile"
866 unlockFile :: CInt -> IO CInt
868 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
870 mkStdHandle fd filepath ha_type buf bmode = do
871 spares <- newIORef BufferListNil
872 newFileHandle filepath stdHandleFinalizer
873 (Handle__ { haFD = fd,
875 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
877 haBufferMode = bmode,
880 haOtherSide = Nothing
883 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
884 mkFileHandle fd is_stream filepath ha_type binary = do
885 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
886 spares <- newIORef BufferListNil
887 newFileHandle filepath handleFinalizer
888 (Handle__ { haFD = fd,
891 haIsStream = is_stream,
892 haBufferMode = bmode,
895 haOtherSide = Nothing
898 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
899 mkDuplexHandle fd is_stream filepath binary = do
900 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
901 w_spares <- newIORef BufferListNil
903 Handle__ { haFD = fd,
904 haType = WriteHandle,
906 haIsStream = is_stream,
907 haBufferMode = w_bmode,
909 haBuffers = w_spares,
910 haOtherSide = Nothing
912 write_side <- newMVar w_handle_
914 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
915 r_spares <- newIORef BufferListNil
917 Handle__ { haFD = fd,
920 haIsStream = is_stream,
921 haBufferMode = r_bmode,
923 haBuffers = r_spares,
924 haOtherSide = Just write_side
926 read_side <- newMVar r_handle_
928 addMVarFinalizer write_side (handleFinalizer write_side)
929 return (DuplexHandle filepath read_side write_side)
932 initBufferState ReadHandle = ReadBuffer
933 initBufferState _ = WriteBuffer
935 -- ---------------------------------------------------------------------------
938 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
939 -- computation finishes, if @hdl@ is writable its buffer is flushed as
941 -- Performing 'hClose' on a handle that has already been closed has no effect;
942 -- doing so not an error. All other operations on a closed handle will fail.
943 -- If 'hClose' fails for any reason, any further operations (apart from
944 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
947 hClose :: Handle -> IO ()
948 hClose h@(FileHandle _ m) = hClose' h m
949 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
951 hClose' h m = withHandle__' "hClose" h m $ hClose_help
953 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
954 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
955 -- then closed immediately. We have to be careful with DuplexHandles
956 -- though: we have to leave the closing to the finalizer in that case,
957 -- because the write side may still be in use.
958 hClose_help :: Handle__ -> IO Handle__
959 hClose_help handle_ =
960 case haType handle_ of
961 ClosedHandle -> return handle_
962 _ -> do flushWriteBufferOnly handle_ -- interruptible
963 hClose_handle_ handle_
965 hClose_handle_ handle_ = do
966 let fd = haFD handle_
967 c_fd = fromIntegral fd
969 -- close the file descriptor, but not when this is the read
970 -- side of a duplex handle, and not when this is one of the
972 case haOtherSide handle_ of
974 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
975 throwErrnoIfMinus1Retry_ "hClose"
976 #ifdef mingw32_TARGET_OS
977 (closeFd (haIsStream handle_) c_fd)
983 -- free the spare buffers
984 writeIORef (haBuffers handle_) BufferListNil
989 -- we must set the fd to -1, because the finalizer is going
990 -- to run eventually and try to close/unlock it.
991 return (handle_{ haFD = -1,
992 haType = ClosedHandle
995 -----------------------------------------------------------------------------
996 -- Detecting the size of a file
998 -- | For a handle @hdl@ which attached to a physical file,
999 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1001 hFileSize :: Handle -> IO Integer
1003 withHandle_ "hFileSize" handle $ \ handle_ -> do
1004 case haType handle_ of
1005 ClosedHandle -> ioe_closedHandle
1006 SemiClosedHandle -> ioe_closedHandle
1007 _ -> do flushWriteBufferOnly handle_
1008 r <- fdFileSize (haFD handle_)
1011 else ioException (IOError Nothing InappropriateType "hFileSize"
1012 "not a regular file" Nothing)
1014 -- ---------------------------------------------------------------------------
1015 -- Detecting the End of Input
1017 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1018 -- 'True' if no further input can be taken from @hdl@ or for a
1019 -- physical file, if the current I\/O position is equal to the length of
1020 -- the file. Otherwise, it returns 'False'.
1022 hIsEOF :: Handle -> IO Bool
1025 (do hLookAhead handle; return False)
1026 (\e -> if isEOFError e then return True else ioError e)
1028 -- | The computation 'isEOF' is identical to 'hIsEOF',
1029 -- except that it works only on 'stdin'.
1032 isEOF = hIsEOF stdin
1034 -- ---------------------------------------------------------------------------
1037 -- | Computation 'hLookAhead' returns the next character from the handle
1038 -- without removing it from the input buffer, blocking until a character
1041 -- This operation may fail with:
1043 -- * 'isEOFError' if the end of file has been reached.
1045 hLookAhead :: Handle -> IO Char
1046 hLookAhead handle = do
1047 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
1048 let ref = haBuffer handle_
1050 is_line = haBufferMode handle_ == LineBuffering
1051 buf <- readIORef ref
1053 -- fill up the read buffer if necessary
1054 new_buf <- if bufferEmpty buf
1055 then fillReadBuffer fd is_line (haIsStream handle_) buf
1058 writeIORef ref new_buf
1060 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1063 -- ---------------------------------------------------------------------------
1064 -- Buffering Operations
1066 -- Three kinds of buffering are supported: line-buffering,
1067 -- block-buffering or no-buffering. See GHC.IOBase for definition and
1068 -- further explanation of what the type represent.
1070 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1071 -- handle @hdl@ on subsequent reads and writes.
1073 -- If the buffer mode is changed from 'BlockBuffering' or
1074 -- 'LineBuffering' to 'NoBuffering', then
1076 -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1078 -- * if @hdl@ is not writable, the contents of the buffer is discarded.
1080 -- This operation may fail with:
1082 -- * 'isPermissionError' if the handle has already been used for reading
1083 -- or writing and the implementation does not allow the buffering mode
1086 hSetBuffering :: Handle -> BufferMode -> IO ()
1087 hSetBuffering handle mode =
1088 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1089 case haType handle_ of
1090 ClosedHandle -> ioe_closedHandle
1093 - we flush the old buffer regardless of whether
1094 the new buffer could fit the contents of the old buffer
1096 - allow a handle's buffering to change even if IO has
1097 occurred (ANSI C spec. does not allow this, nor did
1098 the previous implementation of IO.hSetBuffering).
1099 - a non-standard extension is to allow the buffering
1100 of semi-closed handles to change [sof 6/98]
1104 let state = initBufferState (haType handle_)
1107 -- we always have a 1-character read buffer for
1108 -- unbuffered handles: it's needed to
1109 -- support hLookAhead.
1110 NoBuffering -> allocateBuffer 1 ReadBuffer
1111 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
1112 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1113 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
1114 | otherwise -> allocateBuffer n state
1115 writeIORef (haBuffer handle_) new_buf
1117 -- for input terminals we need to put the terminal into
1118 -- cooked or raw mode depending on the type of buffering.
1119 is_tty <- fdIsTTY (haFD handle_)
1120 when (is_tty && isReadableHandleType (haType handle_)) $
1122 #ifndef mingw32_TARGET_OS
1123 -- 'raw' mode under win32 is a bit too specialised (and troublesome
1124 -- for most common uses), so simply disable its use here.
1125 NoBuffering -> setCooked (haFD handle_) False
1127 _ -> setCooked (haFD handle_) True
1129 -- throw away spare buffers, they might be the wrong size
1130 writeIORef (haBuffers handle_) BufferListNil
1132 return (handle_{ haBufferMode = mode })
1134 -- -----------------------------------------------------------------------------
1137 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1138 -- in handle @hdl@ to be sent immediately to the operating system.
1140 -- This operation may fail with:
1142 -- * 'isFullError' if the device is full;
1144 -- * 'isPermissionError' if a system resource limit would be exceeded.
1145 -- It is unspecified whether the characters in the buffer are discarded
1146 -- or retained under these circumstances.
1148 hFlush :: Handle -> IO ()
1150 wantWritableHandle "hFlush" handle $ \ handle_ -> do
1151 buf <- readIORef (haBuffer handle_)
1152 if bufferIsWritable buf && not (bufferEmpty buf)
1153 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1154 writeIORef (haBuffer handle_) flushed_buf
1158 -- -----------------------------------------------------------------------------
1159 -- Repositioning Handles
1161 data HandlePosn = HandlePosn Handle HandlePosition
1163 instance Eq HandlePosn where
1164 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1166 instance Show HandlePosn where
1167 showsPrec p (HandlePosn h pos) =
1168 showsPrec p h . showString " at position " . shows pos
1170 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1171 -- We represent it as an Integer on the Haskell side, but
1172 -- cheat slightly in that hGetPosn calls upon a C helper
1173 -- that reports the position back via (merely) an Int.
1174 type HandlePosition = Integer
1176 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1177 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1179 hGetPosn :: Handle -> IO HandlePosn
1180 hGetPosn handle = do
1181 posn <- hTell handle
1182 return (HandlePosn handle posn)
1184 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1185 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1186 -- to the position it held at the time of the call to 'hGetPosn'.
1188 -- This operation may fail with:
1190 -- * 'isPermissionError' if a system resource limit would be exceeded.
1192 hSetPosn :: HandlePosn -> IO ()
1193 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1195 -- ---------------------------------------------------------------------------
1198 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1200 = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
1201 | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
1202 -- from the current position.
1203 | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
1204 -- from the end of the file.
1205 deriving (Eq, Ord, Ix, Enum, Read, Show)
1208 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1209 seeking at or past EOF.
1211 - we possibly deviate from the report on the issue of seeking within
1212 the buffer and whether to flush it or not. The report isn't exactly
1216 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1217 -- @hdl@ depending on @mode@.
1218 -- The offset @i@ is given in terms of 8-bit bytes.
1220 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1221 -- in the current buffer will first cause any items in the output buffer to be
1222 -- written to the device, and then cause the input buffer to be discarded.
1223 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1224 -- subset of the possible positioning operations (for instance, it may only
1225 -- be possible to seek to the end of a tape, or to a positive offset from
1226 -- the beginning or current position).
1227 -- It is not possible to set a negative I\/O position, or for
1228 -- a physical file, an I\/O position beyond the current end-of-file.
1230 -- This operation may fail with:
1232 -- * 'isPermissionError' if a system resource limit would be exceeded.
1234 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1235 hSeek handle mode offset =
1236 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1238 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1240 let ref = haBuffer handle_
1241 buf <- readIORef ref
1247 throwErrnoIfMinus1Retry_ "hSeek"
1248 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1251 whence = case mode of
1252 AbsoluteSeek -> sEEK_SET
1253 RelativeSeek -> sEEK_CUR
1254 SeekFromEnd -> sEEK_END
1256 if bufferIsWritable buf
1257 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1258 writeIORef ref new_buf
1262 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1263 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1266 new_buf <- flushReadBuffer (haFD handle_) buf
1267 writeIORef ref new_buf
1271 hTell :: Handle -> IO Integer
1273 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1275 #if defined(mingw32_TARGET_OS)
1276 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1277 -- so we can't easily calculate the file position using the
1278 -- current buffer size. Just flush instead.
1281 let fd = fromIntegral (haFD handle_)
1282 posn <- fromIntegral `liftM`
1283 throwErrnoIfMinus1Retry "hGetPosn"
1284 (c_lseek fd 0 sEEK_CUR)
1286 let ref = haBuffer handle_
1287 buf <- readIORef ref
1290 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1291 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1293 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1294 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1298 -- -----------------------------------------------------------------------------
1299 -- Handle Properties
1301 -- A number of operations return information about the properties of a
1302 -- handle. Each of these operations returns `True' if the handle has
1303 -- the specified property, and `False' otherwise.
1305 hIsOpen :: Handle -> IO Bool
1307 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1308 case haType handle_ of
1309 ClosedHandle -> return False
1310 SemiClosedHandle -> return False
1313 hIsClosed :: Handle -> IO Bool
1315 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1316 case haType handle_ of
1317 ClosedHandle -> return True
1320 {- not defined, nor exported, but mentioned
1321 here for documentation purposes:
1323 hSemiClosed :: Handle -> IO Bool
1327 return (not (ho || hc))
1330 hIsReadable :: Handle -> IO Bool
1331 hIsReadable (DuplexHandle _ _ _) = return True
1332 hIsReadable handle =
1333 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1334 case haType handle_ of
1335 ClosedHandle -> ioe_closedHandle
1336 SemiClosedHandle -> ioe_closedHandle
1337 htype -> return (isReadableHandleType htype)
1339 hIsWritable :: Handle -> IO Bool
1340 hIsWritable (DuplexHandle _ _ _) = return True
1341 hIsWritable handle =
1342 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1343 case haType handle_ of
1344 ClosedHandle -> ioe_closedHandle
1345 SemiClosedHandle -> ioe_closedHandle
1346 htype -> return (isWritableHandleType htype)
1348 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1351 hGetBuffering :: Handle -> IO BufferMode
1352 hGetBuffering handle =
1353 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1354 case haType handle_ of
1355 ClosedHandle -> ioe_closedHandle
1357 -- We're being non-standard here, and allow the buffering
1358 -- of a semi-closed handle to be queried. -- sof 6/98
1359 return (haBufferMode handle_) -- could be stricter..
1361 hIsSeekable :: Handle -> IO Bool
1362 hIsSeekable handle =
1363 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1364 case haType handle_ of
1365 ClosedHandle -> ioe_closedHandle
1366 SemiClosedHandle -> ioe_closedHandle
1367 AppendHandle -> return False
1368 _ -> do t <- fdType (haFD handle_)
1369 return (t == RegularFile
1371 || tEXT_MODE_SEEK_ALLOWED))
1373 -- -----------------------------------------------------------------------------
1374 -- Changing echo status (Non-standard GHC extensions)
1376 -- | Set the echoing status of a handle connected to a terminal.
1378 hSetEcho :: Handle -> Bool -> IO ()
1379 hSetEcho handle on = do
1380 isT <- hIsTerminalDevice handle
1384 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1385 case haType handle_ of
1386 ClosedHandle -> ioe_closedHandle
1387 _ -> setEcho (haFD handle_) on
1389 -- | Get the echoing status of a handle connected to a terminal.
1391 hGetEcho :: Handle -> IO Bool
1392 hGetEcho handle = do
1393 isT <- hIsTerminalDevice handle
1397 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1398 case haType handle_ of
1399 ClosedHandle -> ioe_closedHandle
1400 _ -> getEcho (haFD handle_)
1402 -- | Is the handle connected to a terminal?
1404 hIsTerminalDevice :: Handle -> IO Bool
1405 hIsTerminalDevice handle = do
1406 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1407 case haType handle_ of
1408 ClosedHandle -> ioe_closedHandle
1409 _ -> fdIsTTY (haFD handle_)
1411 -- -----------------------------------------------------------------------------
1414 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1415 -- (See also 'openBinaryFile'.)
1417 hSetBinaryMode :: Handle -> Bool -> IO ()
1418 hSetBinaryMode handle bin =
1419 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1420 do throwErrnoIfMinus1_ "hSetBinaryMode"
1421 (setmode (fromIntegral (haFD handle_)) bin)
1422 return handle_{haIsBin=bin}
1424 foreign import ccall unsafe "__hscore_setmode"
1425 setmode :: CInt -> Bool -> IO CInt
1427 -- -----------------------------------------------------------------------------
1428 -- Duplicating a Handle
1430 -- |Returns a duplicate of the original handle, with its own buffer
1431 -- and file pointer. The original handle's buffer is flushed, including
1432 -- discarding any input data, before the handle is duplicated.
1434 hDuplicate :: Handle -> IO Handle
1435 hDuplicate h@(FileHandle path m) = do
1436 new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1437 new_m <- newMVar new_h_
1438 return (FileHandle path new_m)
1439 hDuplicate h@(DuplexHandle path r w) = do
1440 new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1441 new_w <- newMVar new_w_
1442 new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1443 new_r <- newMVar new_r_
1444 return (DuplexHandle path new_r new_w)
1446 dupHandle_ other_side h_ = do
1447 -- flush the buffer first, so we don't have to copy its contents
1449 new_fd <- c_dup (fromIntegral (haFD h_))
1450 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1451 ioref <- newIORef buffer
1452 ioref_buffers <- newIORef BufferListNil
1454 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1456 haBuffers = ioref_buffers,
1457 haOtherSide = other_side }
1458 return (h_, new_handle_)
1460 -- -----------------------------------------------------------------------------
1461 -- Replacing a Handle
1464 Makes the second handle a duplicate of the first handle. The second
1465 handle will be closed first, if it is not already.
1467 This can be used to retarget the standard Handles, for example:
1469 > do h <- openFile "mystdout" WriteMode
1470 > hDuplicateTo h stdout
1473 hDuplicateTo :: Handle -> Handle -> IO ()
1474 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
1475 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1476 _ <- hClose_help h2_
1477 withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1478 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
1479 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1480 _ <- hClose_help w2_
1481 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1482 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1483 _ <- hClose_help r2_
1484 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1486 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1487 "handles are incompatible" Nothing)
1489 -- ---------------------------------------------------------------------------
1492 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1493 -- than the (pure) instance of 'Show' for 'Handle'.
1495 hShow :: Handle -> IO String
1496 hShow h@(FileHandle path _) = showHandle' path False h
1497 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1499 showHandle' filepath is_duplex h =
1500 withHandle_ "showHandle" h $ \hdl_ ->
1502 showType | is_duplex = showString "duplex (read-write)"
1503 | otherwise = shows (haType hdl_)
1507 showHdl (haType hdl_)
1508 (showString "loc=" . showString filepath . showChar ',' .
1509 showString "type=" . showType . showChar ',' .
1510 showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1511 showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1515 showHdl :: HandleType -> ShowS -> ShowS
1518 ClosedHandle -> shows ht . showString "}"
1521 showBufMode :: Buffer -> BufferMode -> ShowS
1522 showBufMode buf bmo =
1524 NoBuffering -> showString "none"
1525 LineBuffering -> showString "line"
1526 BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1527 BlockBuffering Nothing -> showString "block " . showParen True (shows def)
1532 -- ---------------------------------------------------------------------------
1536 puts :: String -> IO ()
1537 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1541 -- -----------------------------------------------------------------------------
1544 throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
1545 throwErrnoIfMinus1RetryOnBlock loc f on_block =
1548 if (res :: CInt) == -1
1552 then throwErrnoIfMinus1RetryOnBlock loc f on_block
1553 else if err == eWOULDBLOCK || err == eAGAIN
1558 -- -----------------------------------------------------------------------------
1559 -- wrappers to platform-specific constants:
1561 foreign import ccall unsafe "__hscore_supportsTextMode"
1562 tEXT_MODE_SEEK_ALLOWED :: Bool
1564 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1565 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1566 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1567 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt