1 {-# OPTIONS_GHC -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 -----------------------------------------------------------------------------
22 withHandle, withHandle', withHandle_,
23 wantWritableHandle, wantReadableHandle, wantSeekableHandle,
25 newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
26 flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
27 fillReadBuffer, fillReadBufferWithoutBlocking,
28 readRawBuffer, readRawBufferPtr,
29 writeRawBuffer, writeRawBufferPtr,
31 #ifndef mingw32_HOST_OS
35 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
37 stdin, stdout, stderr,
38 IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle,
39 hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
40 hFlush, hDuplicate, hDuplicateTo,
44 HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
45 SeekMode(..), hSeek, hTell,
47 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
48 hSetEcho, hGetEcho, hIsTerminalDevice,
58 import System.Directory.Internals
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 )
79 #if defined(DEBUG_DUMP)
85 -- -----------------------------------------------------------------------------
88 -- hWaitForInput blocks (should use a timeout)
90 -- unbuffered hGetLine is a bit dodgy
92 -- hSetBuffering: can't change buffering on a stream,
93 -- when the read buffer is non-empty? (no way to flush the buffer)
95 -- ---------------------------------------------------------------------------
96 -- Are files opened by default in text or binary mode, if the user doesn't
99 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
101 -- ---------------------------------------------------------------------------
102 -- Creating a new handle
104 newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
105 newFileHandle filepath finalizer hc = do
107 addMVarFinalizer m (finalizer m)
108 return (FileHandle filepath m)
110 -- ---------------------------------------------------------------------------
111 -- Working with Handles
114 In the concurrent world, handles are locked during use. This is done
115 by wrapping an MVar around the handle which acts as a mutex over
116 operations on the handle.
118 To avoid races, we use the following bracketing operations. The idea
119 is to obtain the lock, do some operation and replace the lock again,
120 whether the operation succeeded or failed. We also want to handle the
121 case where the thread receives an exception while processing the IO
122 operation: in these cases we also want to relinquish the lock.
124 There are three versions of @withHandle@: corresponding to the three
125 possible combinations of:
127 - the operation may side-effect the handle
128 - the operation may return a result
130 If the operation generates an error or an exception is raised, the
131 original handle is always replaced [ this is the case at the moment,
132 but we might want to revisit this in the future --SDM ].
135 {-# INLINE withHandle #-}
136 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
137 withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
138 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
140 withHandle' :: String -> Handle -> MVar Handle__
141 -> (Handle__ -> IO (Handle__,a)) -> IO a
142 withHandle' fun h m act =
145 checkBufferInvariants h_
146 (h',v) <- catchException (act h_)
147 (\ err -> putMVar m h_ >>
149 IOException ex -> ioError (augmentIOError ex fun h)
151 checkBufferInvariants h'
155 {-# INLINE withHandle_ #-}
156 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
157 withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
158 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
160 withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
161 withHandle_' fun h m act =
164 checkBufferInvariants h_
165 v <- catchException (act h_)
166 (\ err -> putMVar m h_ >>
168 IOException ex -> ioError (augmentIOError ex fun h)
170 checkBufferInvariants h_
174 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
175 withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
176 withAllHandles__ fun h@(DuplexHandle _ r w) act = do
177 withHandle__' fun h r act
178 withHandle__' fun h w act
180 withHandle__' fun h m act =
183 checkBufferInvariants h_
184 h' <- catchException (act h_)
185 (\ err -> putMVar m h_ >>
187 IOException ex -> ioError (augmentIOError ex fun h)
189 checkBufferInvariants h'
193 augmentIOError (IOError _ iot _ str fp) fun h
194 = IOError (Just h) iot fun str filepath
197 | otherwise = case h of
198 FileHandle fp _ -> Just fp
199 DuplexHandle fp _ _ -> Just fp
201 -- ---------------------------------------------------------------------------
202 -- Wrapper for write operations.
204 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
205 wantWritableHandle fun h@(FileHandle _ m) act
206 = wantWritableHandle' fun h m act
207 wantWritableHandle fun h@(DuplexHandle _ _ m) act
208 = wantWritableHandle' fun h m act
209 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
212 :: String -> Handle -> MVar Handle__
213 -> (Handle__ -> IO a) -> IO a
214 wantWritableHandle' fun h m act
215 = withHandle_' fun h m (checkWritableHandle act)
217 checkWritableHandle act handle_
218 = case haType handle_ of
219 ClosedHandle -> ioe_closedHandle
220 SemiClosedHandle -> ioe_closedHandle
221 ReadHandle -> ioe_notWritable
222 ReadWriteHandle -> do
223 let ref = haBuffer handle_
226 if not (bufferIsWritable buf)
227 then do b <- flushReadBuffer (haFD handle_) buf
228 return b{ bufState=WriteBuffer }
230 writeIORef ref new_buf
232 _other -> act handle_
234 -- ---------------------------------------------------------------------------
235 -- Wrapper for read operations.
237 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
238 wantReadableHandle fun h@(FileHandle _ m) act
239 = wantReadableHandle' fun h m act
240 wantReadableHandle fun h@(DuplexHandle _ m _) act
241 = wantReadableHandle' fun h m act
242 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
245 :: String -> Handle -> MVar Handle__
246 -> (Handle__ -> IO a) -> IO a
247 wantReadableHandle' fun h m act
248 = withHandle_' fun h m (checkReadableHandle act)
250 checkReadableHandle act handle_ =
251 case haType handle_ of
252 ClosedHandle -> ioe_closedHandle
253 SemiClosedHandle -> ioe_closedHandle
254 AppendHandle -> ioe_notReadable
255 WriteHandle -> ioe_notReadable
256 ReadWriteHandle -> do
257 let ref = haBuffer handle_
259 when (bufferIsWritable buf) $ do
260 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
261 writeIORef ref new_buf{ bufState=ReadBuffer }
263 _other -> act handle_
265 -- ---------------------------------------------------------------------------
266 -- Wrapper for seek operations.
268 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
269 wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
270 ioException (IOError (Just h) IllegalOperation fun
271 "handle is not seekable" Nothing)
272 wantSeekableHandle fun h@(FileHandle _ m) act =
273 withHandle_' fun h m (checkSeekableHandle act)
275 checkSeekableHandle act handle_ =
276 case haType handle_ of
277 ClosedHandle -> ioe_closedHandle
278 SemiClosedHandle -> ioe_closedHandle
279 AppendHandle -> ioe_notSeekable
280 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
281 | otherwise -> ioe_notSeekable_notBin
283 -- -----------------------------------------------------------------------------
286 ioe_closedHandle, ioe_EOF,
287 ioe_notReadable, ioe_notWritable,
288 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
290 ioe_closedHandle = ioException
291 (IOError Nothing IllegalOperation ""
292 "handle is closed" Nothing)
293 ioe_EOF = ioException
294 (IOError Nothing EOF "" "" Nothing)
295 ioe_notReadable = ioException
296 (IOError Nothing IllegalOperation ""
297 "handle is not open for reading" Nothing)
298 ioe_notWritable = ioException
299 (IOError Nothing IllegalOperation ""
300 "handle is not open for writing" Nothing)
301 ioe_notSeekable = ioException
302 (IOError Nothing IllegalOperation ""
303 "handle is not seekable" Nothing)
304 ioe_notSeekable_notBin = ioException
305 (IOError Nothing IllegalOperation ""
306 "seek operations on text-mode handles are not allowed on this platform"
309 ioe_finalizedHandle fp = throw (IOException
310 (IOError Nothing IllegalOperation ""
311 "handle is finalized" (Just fp)))
313 ioe_bufsiz :: Int -> IO a
314 ioe_bufsiz n = ioException
315 (IOError Nothing InvalidArgument "hSetBuffering"
316 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
317 -- 9 => should be parens'ified.
319 -- -----------------------------------------------------------------------------
322 -- For a duplex handle, we arrange that the read side points to the write side
323 -- (and hence keeps it alive if the read side is alive). This is done by
324 -- having the haOtherSide field of the read side point to the read side.
325 -- The finalizer is then placed on the write side, and the handle only gets
326 -- finalized once, when both sides are no longer required.
328 -- NOTE about finalized handles: It's possible that a handle can be
329 -- finalized and then we try to use it later, for example if the
330 -- handle is referenced from another finalizer, or from a thread that
331 -- has become unreferenced and then resurrected (arguably in the
332 -- latter case we shouldn't finalize the Handle...). Anyway,
333 -- we try to emit a helpful message which is better than nothing.
335 stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
336 stdHandleFinalizer fp m = do
338 flushWriteBufferOnly h_
339 putMVar m (ioe_finalizedHandle fp)
341 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
342 handleFinalizer fp m = do
343 handle_ <- takeMVar m
344 case haType handle_ of
345 ClosedHandle -> return ()
346 _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
347 -- ignore errors and async exceptions, and close the
348 -- descriptor anyway...
349 hClose_handle_ handle_
351 putMVar m (ioe_finalizedHandle fp)
353 -- ---------------------------------------------------------------------------
354 -- Grimy buffer operations
357 checkBufferInvariants h_ = do
358 let ref = haBuffer h_
359 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
364 && ( r /= w || (r == 0 && w == 0) )
365 && ( state /= WriteBuffer || r == 0 )
366 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
368 then error "buffer invariant violation"
371 checkBufferInvariants h_ = return ()
374 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
375 newEmptyBuffer b state size
376 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
378 allocateBuffer :: Int -> BufferState -> IO Buffer
379 allocateBuffer sz@(I# size) state = IO $ \s ->
380 #ifdef mingw32_HOST_OS
381 -- To implement asynchronous I/O under Win32, we have to pass
382 -- buffer references to external threads that handles the
383 -- filling/emptying of their contents. Hence, the buffer cannot
384 -- be moved around by the GC.
385 case newPinnedByteArray# size s of { (# s, b #) ->
387 case newByteArray# size s of { (# s, b #) ->
389 (# s, newEmptyBuffer b state sz #) }
391 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
392 writeCharIntoBuffer slab (I# off) (C# c)
393 = IO $ \s -> case writeCharArray# slab off c s of
394 s -> (# s, I# (off +# 1#) #)
396 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
397 readCharFromBuffer slab (I# off)
398 = IO $ \s -> case readCharArray# slab off s of
399 (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
401 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
402 getBuffer fd state = do
403 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
404 ioref <- newIORef buffer
408 | is_tty = LineBuffering
409 | otherwise = BlockBuffering Nothing
411 return (ioref, buffer_mode)
413 mkUnBuffer :: IO (IORef Buffer)
415 buffer <- allocateBuffer 1 ReadBuffer
418 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
419 flushWriteBufferOnly :: Handle__ -> IO ()
420 flushWriteBufferOnly h_ = do
424 new_buf <- if bufferIsWritable buf
425 then flushWriteBuffer fd (haIsStream h_) buf
427 writeIORef ref new_buf
429 -- flushBuffer syncs the file with the buffer, including moving the
430 -- file pointer backwards in the case of a read buffer.
431 flushBuffer :: Handle__ -> IO ()
433 let ref = haBuffer h_
438 ReadBuffer -> flushReadBuffer (haFD h_) buf
439 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
441 writeIORef ref flushed_buf
443 -- When flushing a read buffer, we seek backwards by the number of
444 -- characters in the buffer. The file descriptor must therefore be
445 -- seekable: attempting to flush the read buffer on an unseekable
446 -- handle is not allowed.
448 flushReadBuffer :: FD -> Buffer -> IO Buffer
449 flushReadBuffer fd buf
450 | bufferEmpty buf = return buf
452 let off = negate (bufWPtr buf - bufRPtr buf)
454 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
456 throwErrnoIfMinus1Retry "flushReadBuffer"
457 (c_lseek fd (fromIntegral off) sEEK_CUR)
458 return buf{ bufWPtr=0, bufRPtr=0 }
460 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
461 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
462 seq fd $ do -- strictness hack
465 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
468 then return (buf{ bufRPtr=0, bufWPtr=0 })
470 res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
471 (fromIntegral r) (fromIntegral bytes)
472 let res' = fromIntegral res
474 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
475 else return buf{ bufRPtr=0, bufWPtr=0 }
477 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
478 fillReadBuffer fd is_line is_stream
479 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
480 -- buffer better be empty:
481 assert (r == 0 && w == 0) $ do
482 fillReadBufferLoop fd is_line is_stream buf b w size
484 -- For a line buffer, we just get the first chunk of data to arrive,
485 -- and don't wait for the whole buffer to be full (but we *do* wait
486 -- until some data arrives). This isn't really line buffering, but it
487 -- appears to be what GHC has done for a long time, and I suspect it
488 -- is more useful than line buffering in most cases.
490 fillReadBufferLoop fd is_line is_stream buf b w size = do
492 if bytes == 0 -- buffer full?
493 then return buf{ bufRPtr=0, bufWPtr=w }
496 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
498 res <- readRawBuffer "fillReadBuffer" fd is_stream b
499 (fromIntegral w) (fromIntegral bytes)
500 let res' = fromIntegral res
502 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
507 else return buf{ bufRPtr=0, bufWPtr=w }
508 else if res' < bytes && not is_line
509 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
510 else return buf{ bufRPtr=0, bufWPtr=w+res' }
513 fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
514 fillReadBufferWithoutBlocking fd is_stream
515 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
516 -- buffer better be empty:
517 assert (r == 0 && w == 0) $ do
519 puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
521 res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
522 0 (fromIntegral size)
523 let res' = fromIntegral res
525 puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
527 return buf{ bufRPtr=0, bufWPtr=res' }
529 -- Low level routines for reading/writing to (raw)buffers:
531 #ifndef mingw32_HOST_OS
532 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
533 readRawBuffer loc fd is_stream buf off len =
534 throwErrnoIfMinus1RetryMayBlock loc
535 (read_rawBuffer fd buf off len)
536 (threadWaitRead (fromIntegral fd))
538 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
539 readRawBufferNoBlock loc fd is_stream buf off len =
540 throwErrnoIfMinus1RetryOnBlock loc
541 (read_rawBuffer fd buf off len)
544 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
545 readRawBufferPtr loc fd is_stream buf off len =
546 throwErrnoIfMinus1RetryMayBlock loc
547 (read_off fd buf off len)
548 (threadWaitRead (fromIntegral fd))
550 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
551 writeRawBuffer loc fd is_stream buf off len =
552 throwErrnoIfMinus1RetryMayBlock loc
553 (write_rawBuffer fd buf off len)
554 (threadWaitWrite (fromIntegral fd))
556 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
557 writeRawBufferPtr loc fd is_stream buf off len =
558 throwErrnoIfMinus1RetryMayBlock loc
559 (write_off fd buf off len)
560 (threadWaitWrite (fromIntegral fd))
562 foreign import ccall unsafe "__hscore_PrelHandle_read"
563 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
565 foreign import ccall unsafe "__hscore_PrelHandle_read"
566 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
568 foreign import ccall unsafe "__hscore_PrelHandle_write"
569 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
571 foreign import ccall unsafe "__hscore_PrelHandle_write"
572 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
574 #else /* mingw32_HOST_OS.... */
576 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
577 readRawBuffer loc fd is_stream buf off len
578 | threaded = blockingReadRawBuffer loc fd is_stream buf off len
579 | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
581 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
582 readRawBufferPtr loc fd is_stream buf off len
583 | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
584 | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
586 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
587 writeRawBuffer loc fd is_stream buf off len
588 | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
589 | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
591 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
592 writeRawBufferPtr loc fd is_stream buf off len
593 | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
594 | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len
596 -- ToDo: we don't have a non-blocking primitve read on Win32
597 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
598 readRawBufferNoBlock = readRawBuffer
600 -- Async versions of the read/write primitives, for the non-threaded RTS
602 asyncReadRawBuffer loc fd is_stream buf off len = do
603 (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0)
604 (fromIntegral len) off buf
607 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
608 else return (fromIntegral l)
610 asyncReadRawBufferPtr loc fd is_stream buf off len = do
611 (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0)
612 (fromIntegral len) (buf `plusPtr` off)
615 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
616 else return (fromIntegral l)
618 asyncWriteRawBuffer loc fd is_stream buf off len = do
619 (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0)
620 (fromIntegral len) off buf
623 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
624 else return (fromIntegral l)
626 asyncWriteRawBufferPtr loc fd is_stream buf off len = do
627 (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0)
628 (fromIntegral len) (buf `plusPtr` off)
631 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
632 else return (fromIntegral l)
634 -- Blocking versions of the read/write primitives, for the threaded RTS
636 blockingReadRawBuffer loc fd True buf off len =
637 throwErrnoIfMinus1Retry loc $
638 recv_rawBuffer fd buf off len
639 blockingReadRawBuffer loc fd False buf off len =
640 throwErrnoIfMinus1Retry loc $
641 read_rawBuffer fd buf off len
643 blockingReadRawBufferPtr loc fd True buf off len =
644 throwErrnoIfMinus1Retry loc $
645 recv_off fd buf off len
646 blockingReadRawBufferPtr loc fd False buf off len =
647 throwErrnoIfMinus1Retry loc $
648 read_off fd buf off len
650 blockingWriteRawBuffer loc fd True buf off len =
651 throwErrnoIfMinus1Retry loc $
652 send_rawBuffer fd buf off len
653 blockingWriteRawBuffer loc fd False buf off len =
654 throwErrnoIfMinus1Retry loc $
655 write_rawBuffer fd buf off len
657 blockingWriteRawBufferPtr loc fd True buf off len =
658 throwErrnoIfMinus1Retry loc $
659 send_off fd buf off len
660 blockingWriteRawBufferPtr loc fd False buf off len =
661 throwErrnoIfMinus1Retry loc $
662 write_off fd buf off len
664 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
665 -- These calls may block, but that's ok.
667 foreign import ccall safe "__hscore_PrelHandle_read"
668 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
670 foreign import ccall safe "__hscore_PrelHandle_read"
671 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
673 foreign import ccall safe "__hscore_PrelHandle_write"
674 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
676 foreign import ccall safe "__hscore_PrelHandle_write"
677 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
679 foreign import ccall safe "__hscore_PrelHandle_recv"
680 recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
682 foreign import ccall safe "__hscore_PrelHandle_recv"
683 recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
685 foreign import ccall safe "__hscore_PrelHandle_send"
686 send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
688 foreign import ccall safe "__hscore_PrelHandle_send"
689 send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
691 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
694 -- ---------------------------------------------------------------------------
697 -- Three handles are allocated during program initialisation. The first
698 -- two manage input or output from the Haskell program's standard input
699 -- or output channel respectively. The third manages output to the
700 -- standard error channel. These handles are initially open.
706 -- | A handle managing input from the Haskell program's standard input channel.
708 stdin = unsafePerformIO $ do
709 -- ToDo: acquire lock
710 setNonBlockingFD fd_stdin
711 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
712 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
714 -- | A handle managing output to the Haskell program's standard output channel.
716 stdout = unsafePerformIO $ do
717 -- ToDo: acquire lock
718 -- We don't set non-blocking mode on stdout or sterr, because
719 -- some shells don't recover properly.
720 -- setNonBlockingFD fd_stdout
721 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
722 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
724 -- | A handle managing output to the Haskell program's standard error channel.
726 stderr = unsafePerformIO $ do
727 -- ToDo: acquire lock
728 -- We don't set non-blocking mode on stdout or sterr, because
729 -- some shells don't recover properly.
730 -- setNonBlockingFD fd_stderr
732 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
734 -- ---------------------------------------------------------------------------
735 -- Opening and Closing Files
737 addFilePathToIOError fun fp (IOError h iot _ str _)
738 = IOError h iot fun str (Just fp)
740 -- | Computation 'openFile' @file mode@ allocates and returns a new, open
741 -- handle to manage the file @file@. It manages input if @mode@
742 -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
743 -- and both input and output if mode is 'ReadWriteMode'.
745 -- If the file does not exist and it is opened for output, it should be
746 -- created as a new file. If @mode@ is 'WriteMode' and the file
747 -- already exists, then it should be truncated to zero length.
748 -- Some operating systems delete empty files, so there is no guarantee
749 -- that the file will exist following an 'openFile' with @mode@
750 -- 'WriteMode' unless it is subsequently written to successfully.
751 -- The handle is positioned at the end of the file if @mode@ is
752 -- 'AppendMode', and otherwise at the beginning (in which case its
753 -- internal position is 0).
754 -- The initial buffer mode is implementation-dependent.
756 -- This operation may fail with:
758 -- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
760 -- * 'isDoesNotExistError' if the file does not exist; or
762 -- * 'isPermissionError' if the user does not have permission to open the file.
764 -- Note: if you will be working with files containing binary data, you'll want to
765 -- be using 'openBinaryFile'.
766 openFile :: FilePath -> IOMode -> IO Handle
769 (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
770 (\e -> ioError (addFilePathToIOError "openFile" fp e))
772 -- | Like 'openFile', but open the file in binary mode.
773 -- On Windows, reading a file in text mode (which is the default)
774 -- will translate CRLF to LF, and writing will translate LF to CRLF.
775 -- This is usually what you want with text files. With binary files
776 -- this is undesirable; also, as usual under Microsoft operating systems,
777 -- text mode treats control-Z as EOF. Binary mode turns off all special
778 -- treatment of end-of-line and end-of-file characters.
779 -- (See also 'hSetBinaryMode'.)
781 openBinaryFile :: FilePath -> IOMode -> IO Handle
782 openBinaryFile fp m =
784 (openFile' fp m True)
785 (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
787 openFile' filepath mode binary =
788 withCString filepath $ \ f ->
791 oflags1 = case mode of
792 ReadMode -> read_flags
793 #ifdef mingw32_HOST_OS
794 WriteMode -> write_flags .|. o_TRUNC
796 WriteMode -> write_flags
798 ReadWriteMode -> rw_flags
799 AppendMode -> append_flags
805 oflags = oflags1 .|. binary_flags
808 -- the old implementation had a complicated series of three opens,
809 -- which is perhaps because we have to be careful not to open
810 -- directories. However, the man pages I've read say that open()
811 -- always returns EISDIR if the file is a directory and was opened
812 -- for writing, so I think we're ok with a single open() here...
813 fd <- throwErrnoIfMinus1Retry "openFile"
814 (c_open f (fromIntegral oflags) 0o666)
818 h <- openFd fd (Just fd_type) False filepath mode binary
819 `catchException` \e -> do c_close fd; throw e
820 -- NB. don't forget to close the FD if openFd fails, otherwise
822 -- ASSERT: if we just created the file, then openFd won't fail
823 -- (so we don't need to worry about removing the newly created file
824 -- in the event of an error).
826 #ifndef mingw32_HOST_OS
827 -- we want to truncate() if this is an open in WriteMode, but only
828 -- if the target is a RegularFile. ftruncate() fails on special files
830 if mode == WriteMode && fd_type == RegularFile
831 then throwErrnoIf (/=0) "openFile"
838 -- | The function creates a temporary file in ReadWrite mode.
839 -- The created file isn\'t deleted automatically, so you need to delete it manually.
840 openTempFile :: FilePath -- ^ Directory in which to create the file
841 -> String -- ^ File name template. If the template is \"foo.ext\" then
842 -- the create file will be \"fooXXX.ext\" where XXX is some
844 -> IO (FilePath, Handle)
845 openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE
847 -- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
848 openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
849 openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True
851 openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)
852 openTempFile' loc tmp_dir template binary = do
856 (prefix,suffix) = break (=='.') template
858 oflags1 = rw_flags .|. o_EXCL
864 oflags = oflags1 .|. binary_flags
867 fd <- withCString filepath $ \ f ->
868 c_open f oflags 0o666
873 then findTempName (x+1)
874 else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
876 h <- openFd fd Nothing False filepath ReadWriteMode True
877 `catchException` \e -> do c_close fd; throw e
880 filename = prefix ++ show x ++ suffix
881 filepath = tmp_dir `joinFileName` filename
884 std_flags = o_NONBLOCK .|. o_NOCTTY
885 output_flags = std_flags .|. o_CREAT
886 read_flags = std_flags .|. o_RDONLY
887 write_flags = output_flags .|. o_WRONLY
888 rw_flags = output_flags .|. o_RDWR
889 append_flags = write_flags .|. o_APPEND
891 -- ---------------------------------------------------------------------------
894 openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
895 openFd fd mb_fd_type is_socket filepath mode binary = do
896 -- turn on non-blocking mode
899 let (ha_type, write) =
901 ReadMode -> ( ReadHandle, False )
902 WriteMode -> ( WriteHandle, True )
903 ReadWriteMode -> ( ReadWriteHandle, True )
904 AppendMode -> ( AppendHandle, True )
906 -- open() won't tell us if it was a directory if we only opened for
907 -- reading, so check again.
915 ioException (IOError Nothing InappropriateType "openFile"
916 "is a directory" Nothing)
918 -- regular files need to be locked
920 #ifndef mingw32_HOST_OS
921 r <- lockFile fd (fromBool write) 1{-exclusive-}
923 ioException (IOError Nothing ResourceBusy "openFile"
924 "file is locked" Nothing)
926 mkFileHandle fd is_socket filepath ha_type binary
929 -- only *Streams* can be DuplexHandles. Other read/write
930 -- Handles must share a buffer.
931 | ReadWriteHandle <- ha_type ->
932 mkDuplexHandle fd is_socket filepath binary
934 mkFileHandle fd is_socket filepath ha_type binary
937 mkFileHandle fd is_socket filepath ha_type binary
939 fdToHandle :: FD -> IO Handle
942 let fd_str = "<file descriptor: " ++ show fd ++ ">"
943 openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
946 #ifndef mingw32_HOST_OS
947 foreign import ccall unsafe "lockFile"
948 lockFile :: CInt -> CInt -> CInt -> IO CInt
950 foreign import ccall unsafe "unlockFile"
951 unlockFile :: CInt -> IO CInt
954 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
956 mkStdHandle fd filepath ha_type buf bmode = do
957 spares <- newIORef BufferListNil
958 newFileHandle filepath (stdHandleFinalizer filepath)
959 (Handle__ { haFD = fd,
961 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
963 haBufferMode = bmode,
966 haOtherSide = Nothing
969 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
970 mkFileHandle fd is_stream filepath ha_type binary = do
971 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
973 #ifdef mingw32_HOST_OS
974 -- On Windows, if this is a read/write handle and we are in text mode,
975 -- turn off buffering. We don't correctly handle the case of switching
976 -- from read mode to write mode on a buffered text-mode handle, see bug
978 bmode <- case ha_type of
979 ReadWriteHandle | not binary -> return NoBuffering
980 _other -> return bmode
983 spares <- newIORef BufferListNil
984 newFileHandle filepath (handleFinalizer filepath)
985 (Handle__ { haFD = fd,
988 haIsStream = is_stream,
989 haBufferMode = bmode,
992 haOtherSide = Nothing
995 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
996 mkDuplexHandle fd is_stream filepath binary = do
997 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
998 w_spares <- newIORef BufferListNil
1000 Handle__ { haFD = fd,
1001 haType = WriteHandle,
1003 haIsStream = is_stream,
1004 haBufferMode = w_bmode,
1006 haBuffers = w_spares,
1007 haOtherSide = Nothing
1009 write_side <- newMVar w_handle_
1011 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
1012 r_spares <- newIORef BufferListNil
1014 Handle__ { haFD = fd,
1015 haType = ReadHandle,
1017 haIsStream = is_stream,
1018 haBufferMode = r_bmode,
1020 haBuffers = r_spares,
1021 haOtherSide = Just write_side
1023 read_side <- newMVar r_handle_
1025 addMVarFinalizer write_side (handleFinalizer filepath write_side)
1026 return (DuplexHandle filepath read_side write_side)
1029 initBufferState ReadHandle = ReadBuffer
1030 initBufferState _ = WriteBuffer
1032 -- ---------------------------------------------------------------------------
1035 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
1036 -- computation finishes, if @hdl@ is writable its buffer is flushed as
1038 -- Performing 'hClose' on a handle that has already been closed has no effect;
1039 -- doing so not an error. All other operations on a closed handle will fail.
1040 -- If 'hClose' fails for any reason, any further operations (apart from
1041 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
1044 hClose :: Handle -> IO ()
1045 hClose h@(FileHandle _ m) = hClose' h m
1046 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
1048 hClose' h m = withHandle__' "hClose" h m $ hClose_help
1050 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
1051 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
1052 -- then closed immediately. We have to be careful with DuplexHandles
1053 -- though: we have to leave the closing to the finalizer in that case,
1054 -- because the write side may still be in use.
1055 hClose_help :: Handle__ -> IO Handle__
1056 hClose_help handle_ =
1057 case haType handle_ of
1058 ClosedHandle -> return handle_
1059 _ -> do flushWriteBufferOnly handle_ -- interruptible
1060 hClose_handle_ handle_
1062 hClose_handle_ handle_ = do
1063 let fd = haFD handle_
1065 -- close the file descriptor, but not when this is the read
1066 -- side of a duplex handle.
1067 case haOtherSide handle_ of
1069 throwErrnoIfMinus1Retry_ "hClose"
1070 #ifdef mingw32_HOST_OS
1071 (closeFd (haIsStream handle_) fd)
1077 -- free the spare buffers
1078 writeIORef (haBuffers handle_) BufferListNil
1080 #ifndef mingw32_HOST_OS
1085 -- we must set the fd to -1, because the finalizer is going
1086 -- to run eventually and try to close/unlock it.
1087 return (handle_{ haFD = -1,
1088 haType = ClosedHandle
1091 -----------------------------------------------------------------------------
1092 -- Detecting and changing the size of a file
1094 -- | For a handle @hdl@ which attached to a physical file,
1095 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1097 hFileSize :: Handle -> IO Integer
1099 withHandle_ "hFileSize" handle $ \ handle_ -> do
1100 case haType handle_ of
1101 ClosedHandle -> ioe_closedHandle
1102 SemiClosedHandle -> ioe_closedHandle
1103 _ -> do flushWriteBufferOnly handle_
1104 r <- fdFileSize (haFD handle_)
1107 else ioException (IOError Nothing InappropriateType "hFileSize"
1108 "not a regular file" Nothing)
1111 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
1113 hSetFileSize :: Handle -> Integer -> IO ()
1114 hSetFileSize handle size =
1115 withHandle_ "hSetFileSize" handle $ \ handle_ -> do
1116 case haType handle_ of
1117 ClosedHandle -> ioe_closedHandle
1118 SemiClosedHandle -> ioe_closedHandle
1119 _ -> do flushWriteBufferOnly handle_
1120 throwErrnoIf (/=0) "hSetFileSize"
1121 (c_ftruncate (haFD handle_) (fromIntegral size))
1124 -- ---------------------------------------------------------------------------
1125 -- Detecting the End of Input
1127 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1128 -- 'True' if no further input can be taken from @hdl@ or for a
1129 -- physical file, if the current I\/O position is equal to the length of
1130 -- the file. Otherwise, it returns 'False'.
1132 hIsEOF :: Handle -> IO Bool
1135 (do hLookAhead handle; return False)
1136 (\e -> if isEOFError e then return True else ioError e)
1138 -- | The computation 'isEOF' is identical to 'hIsEOF',
1139 -- except that it works only on 'stdin'.
1142 isEOF = hIsEOF stdin
1144 -- ---------------------------------------------------------------------------
1147 -- | Computation 'hLookAhead' returns the next character from the handle
1148 -- without removing it from the input buffer, blocking until a character
1151 -- This operation may fail with:
1153 -- * 'isEOFError' if the end of file has been reached.
1155 hLookAhead :: Handle -> IO Char
1156 hLookAhead handle = do
1157 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
1158 let ref = haBuffer handle_
1160 is_line = haBufferMode handle_ == LineBuffering
1161 buf <- readIORef ref
1163 -- fill up the read buffer if necessary
1164 new_buf <- if bufferEmpty buf
1165 then fillReadBuffer fd True (haIsStream handle_) buf
1168 writeIORef ref new_buf
1170 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1173 -- ---------------------------------------------------------------------------
1174 -- Buffering Operations
1176 -- Three kinds of buffering are supported: line-buffering,
1177 -- block-buffering or no-buffering. See GHC.IOBase for definition and
1178 -- further explanation of what the type represent.
1180 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1181 -- handle @hdl@ on subsequent reads and writes.
1183 -- If the buffer mode is changed from 'BlockBuffering' or
1184 -- 'LineBuffering' to 'NoBuffering', then
1186 -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1188 -- * if @hdl@ is not writable, the contents of the buffer is discarded.
1190 -- This operation may fail with:
1192 -- * 'isPermissionError' if the handle has already been used for reading
1193 -- or writing and the implementation does not allow the buffering mode
1196 hSetBuffering :: Handle -> BufferMode -> IO ()
1197 hSetBuffering handle mode =
1198 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1199 case haType handle_ of
1200 ClosedHandle -> ioe_closedHandle
1203 - we flush the old buffer regardless of whether
1204 the new buffer could fit the contents of the old buffer
1206 - allow a handle's buffering to change even if IO has
1207 occurred (ANSI C spec. does not allow this, nor did
1208 the previous implementation of IO.hSetBuffering).
1209 - a non-standard extension is to allow the buffering
1210 of semi-closed handles to change [sof 6/98]
1214 let state = initBufferState (haType handle_)
1217 -- we always have a 1-character read buffer for
1218 -- unbuffered handles: it's needed to
1219 -- support hLookAhead.
1220 NoBuffering -> allocateBuffer 1 ReadBuffer
1221 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
1222 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1223 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
1224 | otherwise -> allocateBuffer n state
1225 writeIORef (haBuffer handle_) new_buf
1227 -- for input terminals we need to put the terminal into
1228 -- cooked or raw mode depending on the type of buffering.
1229 is_tty <- fdIsTTY (haFD handle_)
1230 when (is_tty && isReadableHandleType (haType handle_)) $
1232 #ifndef mingw32_HOST_OS
1233 -- 'raw' mode under win32 is a bit too specialised (and troublesome
1234 -- for most common uses), so simply disable its use here.
1235 NoBuffering -> setCooked (haFD handle_) False
1237 NoBuffering -> return ()
1239 _ -> setCooked (haFD handle_) True
1241 -- throw away spare buffers, they might be the wrong size
1242 writeIORef (haBuffers handle_) BufferListNil
1244 return (handle_{ haBufferMode = mode })
1246 -- -----------------------------------------------------------------------------
1249 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1250 -- in handle @hdl@ to be sent immediately to the operating system.
1252 -- This operation may fail with:
1254 -- * 'isFullError' if the device is full;
1256 -- * 'isPermissionError' if a system resource limit would be exceeded.
1257 -- It is unspecified whether the characters in the buffer are discarded
1258 -- or retained under these circumstances.
1260 hFlush :: Handle -> IO ()
1262 wantWritableHandle "hFlush" handle $ \ handle_ -> do
1263 buf <- readIORef (haBuffer handle_)
1264 if bufferIsWritable buf && not (bufferEmpty buf)
1265 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1266 writeIORef (haBuffer handle_) flushed_buf
1270 -- -----------------------------------------------------------------------------
1271 -- Repositioning Handles
1273 data HandlePosn = HandlePosn Handle HandlePosition
1275 instance Eq HandlePosn where
1276 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1278 instance Show HandlePosn where
1279 showsPrec p (HandlePosn h pos) =
1280 showsPrec p h . showString " at position " . shows pos
1282 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1283 -- We represent it as an Integer on the Haskell side, but
1284 -- cheat slightly in that hGetPosn calls upon a C helper
1285 -- that reports the position back via (merely) an Int.
1286 type HandlePosition = Integer
1288 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1289 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1291 hGetPosn :: Handle -> IO HandlePosn
1292 hGetPosn handle = do
1293 posn <- hTell handle
1294 return (HandlePosn handle posn)
1296 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1297 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1298 -- to the position it held at the time of the call to 'hGetPosn'.
1300 -- This operation may fail with:
1302 -- * 'isPermissionError' if a system resource limit would be exceeded.
1304 hSetPosn :: HandlePosn -> IO ()
1305 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1307 -- ---------------------------------------------------------------------------
1310 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1312 = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
1313 | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
1314 -- from the current position.
1315 | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
1316 -- from the end of the file.
1317 deriving (Eq, Ord, Ix, Enum, Read, Show)
1320 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1321 seeking at or past EOF.
1323 - we possibly deviate from the report on the issue of seeking within
1324 the buffer and whether to flush it or not. The report isn't exactly
1328 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1329 -- @hdl@ depending on @mode@.
1330 -- The offset @i@ is given in terms of 8-bit bytes.
1332 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1333 -- in the current buffer will first cause any items in the output buffer to be
1334 -- written to the device, and then cause the input buffer to be discarded.
1335 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1336 -- subset of the possible positioning operations (for instance, it may only
1337 -- be possible to seek to the end of a tape, or to a positive offset from
1338 -- the beginning or current position).
1339 -- It is not possible to set a negative I\/O position, or for
1340 -- a physical file, an I\/O position beyond the current end-of-file.
1342 -- This operation may fail with:
1344 -- * 'isPermissionError' if a system resource limit would be exceeded.
1346 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1347 hSeek handle mode offset =
1348 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1350 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1352 let ref = haBuffer handle_
1353 buf <- readIORef ref
1359 throwErrnoIfMinus1Retry_ "hSeek"
1360 (c_lseek (haFD handle_) (fromIntegral offset) whence)
1363 whence = case mode of
1364 AbsoluteSeek -> sEEK_SET
1365 RelativeSeek -> sEEK_CUR
1366 SeekFromEnd -> sEEK_END
1368 if bufferIsWritable buf
1369 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1370 writeIORef ref new_buf
1374 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1375 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1378 new_buf <- flushReadBuffer (haFD handle_) buf
1379 writeIORef ref new_buf
1383 hTell :: Handle -> IO Integer
1385 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1387 #if defined(mingw32_HOST_OS)
1388 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1389 -- so we can't easily calculate the file position using the
1390 -- current buffer size. Just flush instead.
1393 let fd = haFD handle_
1394 posn <- fromIntegral `liftM`
1395 throwErrnoIfMinus1Retry "hGetPosn"
1396 (c_lseek fd 0 sEEK_CUR)
1398 let ref = haBuffer handle_
1399 buf <- readIORef ref
1402 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1403 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1405 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1406 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1410 -- -----------------------------------------------------------------------------
1411 -- Handle Properties
1413 -- A number of operations return information about the properties of a
1414 -- handle. Each of these operations returns `True' if the handle has
1415 -- the specified property, and `False' otherwise.
1417 hIsOpen :: Handle -> IO Bool
1419 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1420 case haType handle_ of
1421 ClosedHandle -> return False
1422 SemiClosedHandle -> return False
1425 hIsClosed :: Handle -> IO Bool
1427 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1428 case haType handle_ of
1429 ClosedHandle -> return True
1432 {- not defined, nor exported, but mentioned
1433 here for documentation purposes:
1435 hSemiClosed :: Handle -> IO Bool
1439 return (not (ho || hc))
1442 hIsReadable :: Handle -> IO Bool
1443 hIsReadable (DuplexHandle _ _ _) = return True
1444 hIsReadable handle =
1445 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1446 case haType handle_ of
1447 ClosedHandle -> ioe_closedHandle
1448 SemiClosedHandle -> ioe_closedHandle
1449 htype -> return (isReadableHandleType htype)
1451 hIsWritable :: Handle -> IO Bool
1452 hIsWritable (DuplexHandle _ _ _) = return True
1453 hIsWritable handle =
1454 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1455 case haType handle_ of
1456 ClosedHandle -> ioe_closedHandle
1457 SemiClosedHandle -> ioe_closedHandle
1458 htype -> return (isWritableHandleType htype)
1460 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1463 hGetBuffering :: Handle -> IO BufferMode
1464 hGetBuffering handle =
1465 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1466 case haType handle_ of
1467 ClosedHandle -> ioe_closedHandle
1469 -- We're being non-standard here, and allow the buffering
1470 -- of a semi-closed handle to be queried. -- sof 6/98
1471 return (haBufferMode handle_) -- could be stricter..
1473 hIsSeekable :: Handle -> IO Bool
1474 hIsSeekable handle =
1475 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1476 case haType handle_ of
1477 ClosedHandle -> ioe_closedHandle
1478 SemiClosedHandle -> ioe_closedHandle
1479 AppendHandle -> return False
1480 _ -> do t <- fdType (haFD handle_)
1481 return ((t == RegularFile || t == RawDevice)
1482 && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
1484 -- -----------------------------------------------------------------------------
1485 -- Changing echo status (Non-standard GHC extensions)
1487 -- | Set the echoing status of a handle connected to a terminal.
1489 hSetEcho :: Handle -> Bool -> IO ()
1490 hSetEcho handle on = do
1491 isT <- hIsTerminalDevice handle
1495 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1496 case haType handle_ of
1497 ClosedHandle -> ioe_closedHandle
1498 _ -> setEcho (haFD handle_) on
1500 -- | Get the echoing status of a handle connected to a terminal.
1502 hGetEcho :: Handle -> IO Bool
1503 hGetEcho handle = do
1504 isT <- hIsTerminalDevice handle
1508 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1509 case haType handle_ of
1510 ClosedHandle -> ioe_closedHandle
1511 _ -> getEcho (haFD handle_)
1513 -- | Is the handle connected to a terminal?
1515 hIsTerminalDevice :: Handle -> IO Bool
1516 hIsTerminalDevice handle = do
1517 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1518 case haType handle_ of
1519 ClosedHandle -> ioe_closedHandle
1520 _ -> fdIsTTY (haFD handle_)
1522 -- -----------------------------------------------------------------------------
1525 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1526 -- (See also 'openBinaryFile'.)
1528 hSetBinaryMode :: Handle -> Bool -> IO ()
1529 hSetBinaryMode handle bin =
1530 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1531 do throwErrnoIfMinus1_ "hSetBinaryMode"
1532 (setmode (haFD handle_) bin)
1533 return handle_{haIsBin=bin}
1535 foreign import ccall unsafe "__hscore_setmode"
1536 setmode :: CInt -> Bool -> IO CInt
1538 -- -----------------------------------------------------------------------------
1539 -- Duplicating a Handle
1541 -- | Returns a duplicate of the original handle, with its own buffer.
1542 -- The two Handles will share a file pointer, however. The original
1543 -- handle's buffer is flushed, including discarding any input data,
1544 -- before the handle is duplicated.
1546 hDuplicate :: Handle -> IO Handle
1547 hDuplicate h@(FileHandle path m) = do
1548 new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
1549 newFileHandle path (handleFinalizer path) new_h_
1550 hDuplicate h@(DuplexHandle path r w) = do
1551 new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
1552 new_w <- newMVar new_w_
1553 new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
1554 new_r <- newMVar new_r_
1555 addMVarFinalizer new_w (handleFinalizer path new_w)
1556 return (DuplexHandle path new_r new_w)
1558 dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
1559 -> IO (Handle__, Handle__)
1560 dupHandle h other_side h_ = do
1561 -- flush the buffer first, so we don't have to copy its contents
1563 new_fd <- case other_side of
1564 Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
1565 Just r -> withHandle_' "dupHandle" h r (return . haFD)
1566 dupHandle_ other_side h_ new_fd
1568 dupHandleTo other_side hto_ h_ = do
1570 -- Windows' dup2 does not return the new descriptor, unlike Unix
1571 throwErrnoIfMinus1 "dupHandleTo" $
1572 c_dup2 (haFD h_) (haFD hto_)
1573 dupHandle_ other_side h_ (haFD hto_)
1575 dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
1576 -> IO (Handle__, Handle__)
1577 dupHandle_ other_side h_ new_fd = do
1578 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1579 ioref <- newIORef buffer
1580 ioref_buffers <- newIORef BufferListNil
1582 let new_handle_ = h_{ haFD = new_fd,
1584 haBuffers = ioref_buffers,
1585 haOtherSide = other_side }
1586 return (h_, new_handle_)
1588 -- -----------------------------------------------------------------------------
1589 -- Replacing a Handle
1592 Makes the second handle a duplicate of the first handle. The second
1593 handle will be closed first, if it is not already.
1595 This can be used to retarget the standard Handles, for example:
1597 > do h <- openFile "mystdout" WriteMode
1598 > hDuplicateTo h stdout
1601 hDuplicateTo :: Handle -> Handle -> IO ()
1602 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
1603 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1604 _ <- hClose_help h2_
1605 withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
1606 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
1607 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1608 _ <- hClose_help w2_
1609 withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
1610 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1611 _ <- hClose_help r2_
1612 withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
1614 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1615 "handles are incompatible" Nothing)
1617 -- ---------------------------------------------------------------------------
1620 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1621 -- than the (pure) instance of 'Show' for 'Handle'.
1623 hShow :: Handle -> IO String
1624 hShow h@(FileHandle path _) = showHandle' path False h
1625 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1627 showHandle' filepath is_duplex h =
1628 withHandle_ "showHandle" h $ \hdl_ ->
1630 showType | is_duplex = showString "duplex (read-write)"
1631 | otherwise = shows (haType hdl_)
1635 showHdl (haType hdl_)
1636 (showString "loc=" . showString filepath . showChar ',' .
1637 showString "type=" . showType . showChar ',' .
1638 showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1639 showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1643 showHdl :: HandleType -> ShowS -> ShowS
1646 ClosedHandle -> shows ht . showString "}"
1649 showBufMode :: Buffer -> BufferMode -> ShowS
1650 showBufMode buf bmo =
1652 NoBuffering -> showString "none"
1653 LineBuffering -> showString "line"
1654 BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1655 BlockBuffering Nothing -> showString "block " . showParen True (shows def)
1660 -- ---------------------------------------------------------------------------
1663 #if defined(DEBUG_DUMP)
1664 puts :: String -> IO ()
1665 puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
1669 -- -----------------------------------------------------------------------------
1672 throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
1673 throwErrnoIfMinus1RetryOnBlock loc f on_block =
1676 if (res :: CInt) == -1
1680 then throwErrnoIfMinus1RetryOnBlock loc f on_block
1681 else if err == eWOULDBLOCK || err == eAGAIN
1686 -- -----------------------------------------------------------------------------
1687 -- wrappers to platform-specific constants:
1689 foreign import ccall unsafe "__hscore_supportsTextMode"
1690 tEXT_MODE_SEEK_ALLOWED :: Bool
1692 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1693 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1694 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1695 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt