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 )
82 -- -----------------------------------------------------------------------------
85 -- hWaitForInput blocks (should use a timeout)
87 -- unbuffered hGetLine is a bit dodgy
89 -- hSetBuffering: can't change buffering on a stream,
90 -- when the read buffer is non-empty? (no way to flush the buffer)
92 -- ---------------------------------------------------------------------------
93 -- Are files opened by default in text or binary mode, if the user doesn't
96 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
98 -- ---------------------------------------------------------------------------
99 -- Creating a new handle
101 newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
102 newFileHandle filepath finalizer hc = do
104 addMVarFinalizer m (finalizer m)
105 return (FileHandle filepath m)
107 -- ---------------------------------------------------------------------------
108 -- Working with Handles
111 In the concurrent world, handles are locked during use. This is done
112 by wrapping an MVar around the handle which acts as a mutex over
113 operations on the handle.
115 To avoid races, we use the following bracketing operations. The idea
116 is to obtain the lock, do some operation and replace the lock again,
117 whether the operation succeeded or failed. We also want to handle the
118 case where the thread receives an exception while processing the IO
119 operation: in these cases we also want to relinquish the lock.
121 There are three versions of @withHandle@: corresponding to the three
122 possible combinations of:
124 - the operation may side-effect the handle
125 - the operation may return a result
127 If the operation generates an error or an exception is raised, the
128 original handle is always replaced [ this is the case at the moment,
129 but we might want to revisit this in the future --SDM ].
132 {-# INLINE withHandle #-}
133 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
134 withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
135 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
137 withHandle' :: String -> Handle -> MVar Handle__
138 -> (Handle__ -> IO (Handle__,a)) -> IO a
139 withHandle' fun h m act =
142 checkBufferInvariants h_
143 (h',v) <- catchException (act h_)
144 (\ err -> putMVar m h_ >>
146 IOException ex -> ioError (augmentIOError ex fun h)
148 checkBufferInvariants h'
152 {-# INLINE withHandle_ #-}
153 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
154 withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
155 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
157 withHandle_' fun h m act =
160 checkBufferInvariants h_
161 v <- catchException (act h_)
162 (\ err -> putMVar m h_ >>
164 IOException ex -> ioError (augmentIOError ex fun h)
166 checkBufferInvariants h_
170 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
171 withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
172 withAllHandles__ fun h@(DuplexHandle _ r w) act = do
173 withHandle__' fun h r act
174 withHandle__' fun h w act
176 withHandle__' fun h m act =
179 checkBufferInvariants h_
180 h' <- catchException (act h_)
181 (\ err -> putMVar m h_ >>
183 IOException ex -> ioError (augmentIOError ex fun h)
185 checkBufferInvariants h'
189 augmentIOError (IOError _ iot _ str fp) fun h
190 = IOError (Just h) iot fun str filepath
193 | otherwise = case h of
194 FileHandle fp _ -> Just fp
195 DuplexHandle fp _ _ -> Just fp
197 -- ---------------------------------------------------------------------------
198 -- Wrapper for write operations.
200 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
201 wantWritableHandle fun h@(FileHandle _ m) act
202 = wantWritableHandle' fun h m act
203 wantWritableHandle fun h@(DuplexHandle _ _ m) act
204 = wantWritableHandle' fun h m act
205 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
208 :: String -> Handle -> MVar Handle__
209 -> (Handle__ -> IO a) -> IO a
210 wantWritableHandle' fun h m act
211 = withHandle_' fun h m (checkWritableHandle act)
213 checkWritableHandle act handle_
214 = case haType handle_ of
215 ClosedHandle -> ioe_closedHandle
216 SemiClosedHandle -> ioe_closedHandle
217 ReadHandle -> ioe_notWritable
218 ReadWriteHandle -> do
219 let ref = haBuffer handle_
222 if not (bufferIsWritable buf)
223 then do b <- flushReadBuffer (haFD handle_) buf
224 return b{ bufState=WriteBuffer }
226 writeIORef ref new_buf
228 _other -> act handle_
230 -- ---------------------------------------------------------------------------
231 -- Wrapper for read operations.
233 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
234 wantReadableHandle fun h@(FileHandle _ m) act
235 = wantReadableHandle' fun h m act
236 wantReadableHandle fun h@(DuplexHandle _ m _) act
237 = wantReadableHandle' fun h m act
238 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
241 :: String -> Handle -> MVar Handle__
242 -> (Handle__ -> IO a) -> IO a
243 wantReadableHandle' fun h m act
244 = withHandle_' fun h m (checkReadableHandle act)
246 checkReadableHandle act handle_ =
247 case haType handle_ of
248 ClosedHandle -> ioe_closedHandle
249 SemiClosedHandle -> ioe_closedHandle
250 AppendHandle -> ioe_notReadable
251 WriteHandle -> ioe_notReadable
252 ReadWriteHandle -> do
253 let ref = haBuffer handle_
255 when (bufferIsWritable buf) $ do
256 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
257 writeIORef ref new_buf{ bufState=ReadBuffer }
259 _other -> act handle_
261 -- ---------------------------------------------------------------------------
262 -- Wrapper for seek operations.
264 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
265 wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
266 ioException (IOError (Just h) IllegalOperation fun
267 "handle is not seekable" Nothing)
268 wantSeekableHandle fun h@(FileHandle _ m) act =
269 withHandle_' fun h m (checkSeekableHandle act)
271 checkSeekableHandle act handle_ =
272 case haType handle_ of
273 ClosedHandle -> ioe_closedHandle
274 SemiClosedHandle -> ioe_closedHandle
275 AppendHandle -> ioe_notSeekable
276 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
277 | otherwise -> ioe_notSeekable_notBin
279 -- -----------------------------------------------------------------------------
282 ioe_closedHandle, ioe_EOF,
283 ioe_notReadable, ioe_notWritable,
284 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
286 ioe_closedHandle = ioException
287 (IOError Nothing IllegalOperation ""
288 "handle is closed" Nothing)
289 ioe_EOF = ioException
290 (IOError Nothing EOF "" "" Nothing)
291 ioe_notReadable = ioException
292 (IOError Nothing IllegalOperation ""
293 "handle is not open for reading" Nothing)
294 ioe_notWritable = ioException
295 (IOError Nothing IllegalOperation ""
296 "handle is not open for writing" Nothing)
297 ioe_notSeekable = ioException
298 (IOError Nothing IllegalOperation ""
299 "handle is not seekable" Nothing)
300 ioe_notSeekable_notBin = ioException
301 (IOError Nothing IllegalOperation ""
302 "seek operations on text-mode handles are not allowed on this platform"
305 ioe_finalizedHandle fp = throw (IOException
306 (IOError Nothing IllegalOperation ""
307 "handle is finalized" (Just fp)))
309 ioe_bufsiz :: Int -> IO a
310 ioe_bufsiz n = ioException
311 (IOError Nothing InvalidArgument "hSetBuffering"
312 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
313 -- 9 => should be parens'ified.
315 -- -----------------------------------------------------------------------------
318 -- For a duplex handle, we arrange that the read side points to the write side
319 -- (and hence keeps it alive if the read side is alive). This is done by
320 -- having the haOtherSide field of the read side point to the read side.
321 -- The finalizer is then placed on the write side, and the handle only gets
322 -- finalized once, when both sides are no longer required.
324 -- NOTE about finalized handles: It's possible that a handle can be
325 -- finalized and then we try to use it later, for example if the
326 -- handle is referenced from another finalizer, or from a thread that
327 -- has become unreferenced and then resurrected (arguably in the
328 -- latter case we shouldn't finalize the Handle...). Anyway,
329 -- we try to emit a helpful message which is better than nothing.
331 stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
332 stdHandleFinalizer fp m = do
334 flushWriteBufferOnly h_
335 putMVar m (ioe_finalizedHandle fp)
337 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
338 handleFinalizer fp m = do
339 handle_ <- takeMVar m
340 case haType handle_ of
341 ClosedHandle -> return ()
342 _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
343 -- ignore errors and async exceptions, and close the
344 -- descriptor anyway...
345 hClose_handle_ handle_
347 putMVar m (ioe_finalizedHandle fp)
349 -- ---------------------------------------------------------------------------
350 -- Grimy buffer operations
353 checkBufferInvariants h_ = do
354 let ref = haBuffer h_
355 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
360 && ( r /= w || (r == 0 && w == 0) )
361 && ( state /= WriteBuffer || r == 0 )
362 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
364 then error "buffer invariant violation"
367 checkBufferInvariants h_ = return ()
370 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
371 newEmptyBuffer b state size
372 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
374 allocateBuffer :: Int -> BufferState -> IO Buffer
375 allocateBuffer sz@(I# size) state = IO $ \s ->
376 #ifdef mingw32_HOST_OS
377 -- To implement asynchronous I/O under Win32, we have to pass
378 -- buffer references to external threads that handles the
379 -- filling/emptying of their contents. Hence, the buffer cannot
380 -- be moved around by the GC.
381 case newPinnedByteArray# size s of { (# s, b #) ->
383 case newByteArray# size s of { (# s, b #) ->
385 (# s, newEmptyBuffer b state sz #) }
387 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
388 writeCharIntoBuffer slab (I# off) (C# c)
389 = IO $ \s -> case writeCharArray# slab off c s of
390 s -> (# s, I# (off +# 1#) #)
392 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
393 readCharFromBuffer slab (I# off)
394 = IO $ \s -> case readCharArray# slab off s of
395 (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
397 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
398 getBuffer fd state = do
399 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
400 ioref <- newIORef buffer
404 | is_tty = LineBuffering
405 | otherwise = BlockBuffering Nothing
407 return (ioref, buffer_mode)
409 mkUnBuffer :: IO (IORef Buffer)
411 buffer <- allocateBuffer 1 ReadBuffer
414 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
415 flushWriteBufferOnly :: Handle__ -> IO ()
416 flushWriteBufferOnly h_ = do
420 new_buf <- if bufferIsWritable buf
421 then flushWriteBuffer fd (haIsStream h_) buf
423 writeIORef ref new_buf
425 -- flushBuffer syncs the file with the buffer, including moving the
426 -- file pointer backwards in the case of a read buffer.
427 flushBuffer :: Handle__ -> IO ()
429 let ref = haBuffer h_
434 ReadBuffer -> flushReadBuffer (haFD h_) buf
435 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
437 writeIORef ref flushed_buf
439 -- When flushing a read buffer, we seek backwards by the number of
440 -- characters in the buffer. The file descriptor must therefore be
441 -- seekable: attempting to flush the read buffer on an unseekable
442 -- handle is not allowed.
444 flushReadBuffer :: FD -> Buffer -> IO Buffer
445 flushReadBuffer fd buf
446 | bufferEmpty buf = return buf
448 let off = negate (bufWPtr buf - bufRPtr buf)
450 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
452 throwErrnoIfMinus1Retry "flushReadBuffer"
453 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
454 return buf{ bufWPtr=0, bufRPtr=0 }
456 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
457 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
458 seq fd $ do -- strictness hack
461 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
464 then return (buf{ bufRPtr=0, bufWPtr=0 })
466 res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
467 (fromIntegral r) (fromIntegral bytes)
468 let res' = fromIntegral res
470 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
471 else return buf{ bufRPtr=0, bufWPtr=0 }
473 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
474 fillReadBuffer fd is_line is_stream
475 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
476 -- buffer better be empty:
477 assert (r == 0 && w == 0) $ do
478 fillReadBufferLoop fd is_line is_stream buf b w size
480 -- For a line buffer, we just get the first chunk of data to arrive,
481 -- and don't wait for the whole buffer to be full (but we *do* wait
482 -- until some data arrives). This isn't really line buffering, but it
483 -- appears to be what GHC has done for a long time, and I suspect it
484 -- is more useful than line buffering in most cases.
486 fillReadBufferLoop fd is_line is_stream buf b w size = do
488 if bytes == 0 -- buffer full?
489 then return buf{ bufRPtr=0, bufWPtr=w }
492 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
494 res <- readRawBuffer "fillReadBuffer" fd is_stream b
495 (fromIntegral w) (fromIntegral bytes)
496 let res' = fromIntegral res
498 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
503 else return buf{ bufRPtr=0, bufWPtr=w }
504 else if res' < bytes && not is_line
505 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
506 else return buf{ bufRPtr=0, bufWPtr=w+res' }
509 fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
510 fillReadBufferWithoutBlocking fd is_stream
511 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
512 -- buffer better be empty:
513 assert (r == 0 && w == 0) $ do
515 puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
517 res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
518 0 (fromIntegral size)
519 let res' = fromIntegral res
521 puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
523 return buf{ bufRPtr=0, bufWPtr=res' }
525 -- Low level routines for reading/writing to (raw)buffers:
527 #ifndef mingw32_HOST_OS
528 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
529 readRawBuffer loc fd is_stream buf off len =
530 throwErrnoIfMinus1RetryMayBlock loc
531 (read_rawBuffer fd buf off len)
532 (threadWaitRead (fromIntegral fd))
534 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
535 readRawBufferNoBlock loc fd is_stream buf off len =
536 throwErrnoIfMinus1RetryOnBlock loc
537 (read_rawBuffer fd buf off len)
540 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
541 readRawBufferPtr loc fd is_stream buf off len =
542 throwErrnoIfMinus1RetryMayBlock loc
543 (read_off fd buf off len)
544 (threadWaitRead (fromIntegral fd))
546 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
547 writeRawBuffer loc fd is_stream buf off len =
548 throwErrnoIfMinus1RetryMayBlock loc
549 (write_rawBuffer (fromIntegral fd) buf off len)
550 (threadWaitWrite (fromIntegral fd))
552 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
553 writeRawBufferPtr loc fd is_stream buf off len =
554 throwErrnoIfMinus1RetryMayBlock loc
555 (write_off (fromIntegral fd) buf off len)
556 (threadWaitWrite (fromIntegral fd))
558 foreign import ccall unsafe "__hscore_PrelHandle_read"
559 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
561 foreign import ccall unsafe "__hscore_PrelHandle_read"
562 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
564 foreign import ccall unsafe "__hscore_PrelHandle_write"
565 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
567 foreign import ccall unsafe "__hscore_PrelHandle_write"
568 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
570 #else /* mingw32_HOST_OS.... */
572 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
573 readRawBuffer loc fd is_stream buf off len
574 | threaded = blockingReadRawBuffer loc fd is_stream buf off len
575 | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
577 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
578 readRawBufferPtr loc fd is_stream buf off len
579 | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
580 | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
582 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
583 writeRawBuffer loc fd is_stream buf off len
584 | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
585 | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
587 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
588 writeRawBufferPtr loc fd is_stream buf off len
589 | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
590 | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len
592 -- ToDo: we don't have a non-blocking primitve read on Win32
593 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
594 readRawBufferNoBlock = readRawBufferNoBlock
596 -- Async versions of the read/write primitives, for the non-threaded RTS
598 asyncReadRawBuffer loc fd is_stream buf off len = do
599 (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0)
600 (fromIntegral len) off buf
603 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
604 else return (fromIntegral l)
606 asyncReadRawBufferPtr loc fd is_stream buf off len = do
607 (l, rc) <- asyncRead fd (if is_stream then 1 else 0)
608 (fromIntegral len) (buf `plusPtr` off)
611 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
612 else return (fromIntegral l)
614 asyncWriteRawBuffer loc fd is_stream buf off len = do
615 (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0)
616 (fromIntegral len) off buf
619 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
620 else return (fromIntegral l)
622 asyncWriteRawBufferPtr loc fd is_stream buf off len = do
623 (l, rc) <- asyncWrite fd (if is_stream then 1 else 0)
624 (fromIntegral len) (buf `plusPtr` off)
627 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
628 else return (fromIntegral l)
630 -- Blocking versions of the read/write primitives, for the threaded RTS
632 blockingReadRawBuffer loc fd True buf off len =
633 throwErrnoIfMinus1Retry loc $
634 recv_rawBuffer fd buf off len
635 blockingReadRawBuffer loc fd False buf off len =
636 throwErrnoIfMinus1Retry loc $
637 read_rawBuffer fd buf off len
639 blockingReadRawBufferPtr loc fd True buf off len =
640 throwErrnoIfMinus1Retry loc $
641 recv_off fd buf off len
642 blockingReadRawBufferPtr loc fd False buf off len =
643 throwErrnoIfMinus1Retry loc $
644 read_off fd buf off len
646 blockingWriteRawBuffer loc fd True buf off len =
647 throwErrnoIfMinus1Retry loc $
648 send_rawBuffer (fromIntegral fd) buf off len
649 blockingWriteRawBuffer loc fd False buf off len =
650 throwErrnoIfMinus1Retry loc $
651 write_rawBuffer (fromIntegral fd) buf off len
653 blockingWriteRawBufferPtr loc fd True buf off len =
654 throwErrnoIfMinus1Retry loc $
655 send_off (fromIntegral fd) buf off len
656 blockingWriteRawBufferPtr loc fd False buf off len =
657 throwErrnoIfMinus1Retry loc $
658 write_off (fromIntegral fd) buf off len
660 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
661 -- These calls may block, but that's ok.
663 foreign import ccall safe "__hscore_PrelHandle_read"
664 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
666 foreign import ccall safe "__hscore_PrelHandle_read"
667 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
669 foreign import ccall safe "__hscore_PrelHandle_write"
670 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
672 foreign import ccall safe "__hscore_PrelHandle_write"
673 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
675 foreign import ccall safe "__hscore_PrelHandle_recv"
676 recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
678 foreign import ccall safe "__hscore_PrelHandle_recv"
679 recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
681 foreign import ccall safe "__hscore_PrelHandle_send"
682 send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
684 foreign import ccall safe "__hscore_PrelHandle_send"
685 send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
687 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
690 -- ---------------------------------------------------------------------------
693 -- Three handles are allocated during program initialisation. The first
694 -- two manage input or output from the Haskell program's standard input
695 -- or output channel respectively. The third manages output to the
696 -- standard error channel. These handles are initially open.
702 -- | A handle managing input from the Haskell program's standard input channel.
704 stdin = unsafePerformIO $ do
705 -- ToDo: acquire lock
706 setNonBlockingFD fd_stdin
707 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
708 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
710 -- | A handle managing output to the Haskell program's standard output channel.
712 stdout = unsafePerformIO $ do
713 -- ToDo: acquire lock
714 -- We don't set non-blocking mode on stdout or sterr, because
715 -- some shells don't recover properly.
716 -- setNonBlockingFD fd_stdout
717 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
718 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
720 -- | A handle managing output to the Haskell program's standard error channel.
722 stderr = unsafePerformIO $ do
723 -- ToDo: acquire lock
724 -- We don't set non-blocking mode on stdout or sterr, because
725 -- some shells don't recover properly.
726 -- setNonBlockingFD fd_stderr
728 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
730 -- ---------------------------------------------------------------------------
731 -- Opening and Closing Files
733 addFilePathToIOError fun fp (IOError h iot _ str _)
734 = IOError h iot fun str (Just fp)
736 -- | Computation 'openFile' @file mode@ allocates and returns a new, open
737 -- handle to manage the file @file@. It manages input if @mode@
738 -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
739 -- and both input and output if mode is 'ReadWriteMode'.
741 -- If the file does not exist and it is opened for output, it should be
742 -- created as a new file. If @mode@ is 'WriteMode' and the file
743 -- already exists, then it should be truncated to zero length.
744 -- Some operating systems delete empty files, so there is no guarantee
745 -- that the file will exist following an 'openFile' with @mode@
746 -- 'WriteMode' unless it is subsequently written to successfully.
747 -- The handle is positioned at the end of the file if @mode@ is
748 -- 'AppendMode', and otherwise at the beginning (in which case its
749 -- internal position is 0).
750 -- The initial buffer mode is implementation-dependent.
752 -- This operation may fail with:
754 -- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
756 -- * 'isDoesNotExistError' if the file does not exist; or
758 -- * 'isPermissionError' if the user does not have permission to open the file.
760 -- Note: if you will be working with files containing binary data, you'll want to
761 -- be using 'openBinaryFile'.
762 openFile :: FilePath -> IOMode -> IO Handle
765 (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
766 (\e -> ioError (addFilePathToIOError "openFile" fp e))
768 -- | Like 'openFile', but open the file in binary mode.
769 -- On Windows, reading a file in text mode (which is the default)
770 -- will translate CRLF to LF, and writing will translate LF to CRLF.
771 -- This is usually what you want with text files. With binary files
772 -- this is undesirable; also, as usual under Microsoft operating systems,
773 -- text mode treats control-Z as EOF. Binary mode turns off all special
774 -- treatment of end-of-line and end-of-file characters.
775 -- (See also 'hSetBinaryMode'.)
777 openBinaryFile :: FilePath -> IOMode -> IO Handle
778 openBinaryFile fp m =
780 (openFile' fp m True)
781 (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
783 openFile' filepath mode binary =
784 withCString filepath $ \ f ->
787 oflags1 = case mode of
788 ReadMode -> read_flags
789 #ifdef mingw32_HOST_OS
790 WriteMode -> write_flags .|. o_TRUNC
792 WriteMode -> write_flags
794 ReadWriteMode -> rw_flags
795 AppendMode -> append_flags
801 oflags = oflags1 .|. binary_flags
804 -- the old implementation had a complicated series of three opens,
805 -- which is perhaps because we have to be careful not to open
806 -- directories. However, the man pages I've read say that open()
807 -- always returns EISDIR if the file is a directory and was opened
808 -- for writing, so I think we're ok with a single open() here...
809 fd <- fromIntegral `liftM`
810 throwErrnoIfMinus1Retry "openFile"
811 (c_open f (fromIntegral oflags) 0o666)
813 h <- openFd fd Nothing False filepath mode binary
814 `catchException` \e -> do c_close (fromIntegral fd); throw e
815 -- NB. don't forget to close the FD if openFd fails, otherwise
817 -- ASSERT: if we just created the file, then openFd won't fail
818 -- (so we don't need to worry about removing the newly created file
819 -- in the event of an error).
820 #ifndef mingw32_HOST_OS
822 then throwErrnoIf (/=0) "openFile"
823 (c_ftruncate (fromIntegral fd) 0)
829 -- | The function creates a temporary file in ReadWrite mode.
830 -- The created file isn\'t deleted automatically, so you need to delete it manually.
831 openTempFile :: FilePath -- ^ Directory in which to create the file
832 -> String -- ^ File name template. If the template is \"foo.ext\" then
833 -- the create file will be \"fooXXX.ext\" where XXX is some
835 -> IO (FilePath, Handle)
836 openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE
838 -- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
839 openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
840 openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True
842 openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)
843 openTempFile' loc tmp_dir template binary = do
847 (prefix,suffix) = break (=='.') template
849 oflags1 = rw_flags .|. o_EXCL
855 oflags = oflags1 .|. binary_flags
858 fd <- withCString filepath $ \ f ->
859 c_open f oflags 0o666
864 then findTempName (x+1)
865 else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
867 h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True
868 `catchException` \e -> do c_close (fromIntegral fd); throw e
871 filename = prefix ++ show x ++ suffix
872 filepath = tmp_dir `joinFileName` filename
875 std_flags = o_NONBLOCK .|. o_NOCTTY
876 output_flags = std_flags .|. o_CREAT
877 read_flags = std_flags .|. o_RDONLY
878 write_flags = output_flags .|. o_WRONLY
879 rw_flags = output_flags .|. o_RDWR
880 append_flags = write_flags .|. o_APPEND
882 -- ---------------------------------------------------------------------------
885 openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
886 openFd fd mb_fd_type is_socket filepath mode binary = do
887 -- turn on non-blocking mode
890 let (ha_type, write) =
892 ReadMode -> ( ReadHandle, False )
893 WriteMode -> ( WriteHandle, True )
894 ReadWriteMode -> ( ReadWriteHandle, True )
895 AppendMode -> ( AppendHandle, True )
897 -- open() won't tell us if it was a directory if we only opened for
898 -- reading, so check again.
906 ioException (IOError Nothing InappropriateType "openFile"
907 "is a directory" Nothing)
910 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
911 | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
913 -- regular files need to be locked
915 #ifndef mingw32_HOST_OS
916 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
918 ioException (IOError Nothing ResourceBusy "openFile"
919 "file is locked" Nothing)
921 mkFileHandle fd is_socket filepath ha_type binary
924 fdToHandle :: FD -> IO Handle
927 let fd_str = "<file descriptor: " ++ show fd ++ ">"
928 openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
931 #ifndef mingw32_HOST_OS
932 foreign import ccall unsafe "lockFile"
933 lockFile :: CInt -> CInt -> CInt -> IO CInt
935 foreign import ccall unsafe "unlockFile"
936 unlockFile :: CInt -> IO CInt
939 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
941 mkStdHandle fd filepath ha_type buf bmode = do
942 spares <- newIORef BufferListNil
943 newFileHandle filepath (stdHandleFinalizer filepath)
944 (Handle__ { haFD = fd,
946 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
948 haBufferMode = bmode,
951 haOtherSide = Nothing
954 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
955 mkFileHandle fd is_stream filepath ha_type binary = do
956 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
957 spares <- newIORef BufferListNil
958 newFileHandle filepath (handleFinalizer filepath)
959 (Handle__ { haFD = fd,
962 haIsStream = is_stream,
963 haBufferMode = bmode,
966 haOtherSide = Nothing
969 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
970 mkDuplexHandle fd is_stream filepath binary = do
971 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
972 w_spares <- newIORef BufferListNil
974 Handle__ { haFD = fd,
975 haType = WriteHandle,
977 haIsStream = is_stream,
978 haBufferMode = w_bmode,
980 haBuffers = w_spares,
981 haOtherSide = Nothing
983 write_side <- newMVar w_handle_
985 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
986 r_spares <- newIORef BufferListNil
988 Handle__ { haFD = fd,
991 haIsStream = is_stream,
992 haBufferMode = r_bmode,
994 haBuffers = r_spares,
995 haOtherSide = Just write_side
997 read_side <- newMVar r_handle_
999 addMVarFinalizer write_side (handleFinalizer filepath write_side)
1000 return (DuplexHandle filepath read_side write_side)
1003 initBufferState ReadHandle = ReadBuffer
1004 initBufferState _ = WriteBuffer
1006 -- ---------------------------------------------------------------------------
1009 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
1010 -- computation finishes, if @hdl@ is writable its buffer is flushed as
1012 -- Performing 'hClose' on a handle that has already been closed has no effect;
1013 -- doing so not an error. All other operations on a closed handle will fail.
1014 -- If 'hClose' fails for any reason, any further operations (apart from
1015 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
1018 hClose :: Handle -> IO ()
1019 hClose h@(FileHandle _ m) = hClose' h m
1020 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
1022 hClose' h m = withHandle__' "hClose" h m $ hClose_help
1024 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
1025 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
1026 -- then closed immediately. We have to be careful with DuplexHandles
1027 -- though: we have to leave the closing to the finalizer in that case,
1028 -- because the write side may still be in use.
1029 hClose_help :: Handle__ -> IO Handle__
1030 hClose_help handle_ =
1031 case haType handle_ of
1032 ClosedHandle -> return handle_
1033 _ -> do flushWriteBufferOnly handle_ -- interruptible
1034 hClose_handle_ handle_
1036 hClose_handle_ handle_ = do
1037 let fd = haFD handle_
1038 c_fd = fromIntegral fd
1040 -- close the file descriptor, but not when this is the read
1041 -- side of a duplex handle.
1042 case haOtherSide handle_ of
1044 throwErrnoIfMinus1Retry_ "hClose"
1045 #ifdef mingw32_HOST_OS
1046 (closeFd (haIsStream handle_) c_fd)
1052 -- free the spare buffers
1053 writeIORef (haBuffers handle_) BufferListNil
1055 #ifndef mingw32_HOST_OS
1060 -- we must set the fd to -1, because the finalizer is going
1061 -- to run eventually and try to close/unlock it.
1062 return (handle_{ haFD = -1,
1063 haType = ClosedHandle
1066 -----------------------------------------------------------------------------
1067 -- Detecting and changing the size of a file
1069 -- | For a handle @hdl@ which attached to a physical file,
1070 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1072 hFileSize :: Handle -> IO Integer
1074 withHandle_ "hFileSize" handle $ \ handle_ -> do
1075 case haType handle_ of
1076 ClosedHandle -> ioe_closedHandle
1077 SemiClosedHandle -> ioe_closedHandle
1078 _ -> do flushWriteBufferOnly handle_
1079 r <- fdFileSize (haFD handle_)
1082 else ioException (IOError Nothing InappropriateType "hFileSize"
1083 "not a regular file" Nothing)
1086 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
1088 hSetFileSize :: Handle -> Integer -> IO ()
1089 hSetFileSize handle size =
1090 withHandle_ "hSetFileSize" handle $ \ handle_ -> do
1091 case haType handle_ of
1092 ClosedHandle -> ioe_closedHandle
1093 SemiClosedHandle -> ioe_closedHandle
1094 _ -> do flushWriteBufferOnly handle_
1095 throwErrnoIf (/=0) "hSetFileSize"
1096 (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
1099 -- ---------------------------------------------------------------------------
1100 -- Detecting the End of Input
1102 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1103 -- 'True' if no further input can be taken from @hdl@ or for a
1104 -- physical file, if the current I\/O position is equal to the length of
1105 -- the file. Otherwise, it returns 'False'.
1107 hIsEOF :: Handle -> IO Bool
1110 (do hLookAhead handle; return False)
1111 (\e -> if isEOFError e then return True else ioError e)
1113 -- | The computation 'isEOF' is identical to 'hIsEOF',
1114 -- except that it works only on 'stdin'.
1117 isEOF = hIsEOF stdin
1119 -- ---------------------------------------------------------------------------
1122 -- | Computation 'hLookAhead' returns the next character from the handle
1123 -- without removing it from the input buffer, blocking until a character
1126 -- This operation may fail with:
1128 -- * 'isEOFError' if the end of file has been reached.
1130 hLookAhead :: Handle -> IO Char
1131 hLookAhead handle = do
1132 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
1133 let ref = haBuffer handle_
1135 is_line = haBufferMode handle_ == LineBuffering
1136 buf <- readIORef ref
1138 -- fill up the read buffer if necessary
1139 new_buf <- if bufferEmpty buf
1140 then fillReadBuffer fd is_line (haIsStream handle_) buf
1143 writeIORef ref new_buf
1145 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1148 -- ---------------------------------------------------------------------------
1149 -- Buffering Operations
1151 -- Three kinds of buffering are supported: line-buffering,
1152 -- block-buffering or no-buffering. See GHC.IOBase for definition and
1153 -- further explanation of what the type represent.
1155 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1156 -- handle @hdl@ on subsequent reads and writes.
1158 -- If the buffer mode is changed from 'BlockBuffering' or
1159 -- 'LineBuffering' to 'NoBuffering', then
1161 -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1163 -- * if @hdl@ is not writable, the contents of the buffer is discarded.
1165 -- This operation may fail with:
1167 -- * 'isPermissionError' if the handle has already been used for reading
1168 -- or writing and the implementation does not allow the buffering mode
1171 hSetBuffering :: Handle -> BufferMode -> IO ()
1172 hSetBuffering handle mode =
1173 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1174 case haType handle_ of
1175 ClosedHandle -> ioe_closedHandle
1178 - we flush the old buffer regardless of whether
1179 the new buffer could fit the contents of the old buffer
1181 - allow a handle's buffering to change even if IO has
1182 occurred (ANSI C spec. does not allow this, nor did
1183 the previous implementation of IO.hSetBuffering).
1184 - a non-standard extension is to allow the buffering
1185 of semi-closed handles to change [sof 6/98]
1189 let state = initBufferState (haType handle_)
1192 -- we always have a 1-character read buffer for
1193 -- unbuffered handles: it's needed to
1194 -- support hLookAhead.
1195 NoBuffering -> allocateBuffer 1 ReadBuffer
1196 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
1197 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1198 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
1199 | otherwise -> allocateBuffer n state
1200 writeIORef (haBuffer handle_) new_buf
1202 -- for input terminals we need to put the terminal into
1203 -- cooked or raw mode depending on the type of buffering.
1204 is_tty <- fdIsTTY (haFD handle_)
1205 when (is_tty && isReadableHandleType (haType handle_)) $
1207 #ifndef mingw32_HOST_OS
1208 -- 'raw' mode under win32 is a bit too specialised (and troublesome
1209 -- for most common uses), so simply disable its use here.
1210 NoBuffering -> setCooked (haFD handle_) False
1212 _ -> setCooked (haFD handle_) True
1214 -- throw away spare buffers, they might be the wrong size
1215 writeIORef (haBuffers handle_) BufferListNil
1217 return (handle_{ haBufferMode = mode })
1219 -- -----------------------------------------------------------------------------
1222 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1223 -- in handle @hdl@ to be sent immediately to the operating system.
1225 -- This operation may fail with:
1227 -- * 'isFullError' if the device is full;
1229 -- * 'isPermissionError' if a system resource limit would be exceeded.
1230 -- It is unspecified whether the characters in the buffer are discarded
1231 -- or retained under these circumstances.
1233 hFlush :: Handle -> IO ()
1235 wantWritableHandle "hFlush" handle $ \ handle_ -> do
1236 buf <- readIORef (haBuffer handle_)
1237 if bufferIsWritable buf && not (bufferEmpty buf)
1238 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1239 writeIORef (haBuffer handle_) flushed_buf
1243 -- -----------------------------------------------------------------------------
1244 -- Repositioning Handles
1246 data HandlePosn = HandlePosn Handle HandlePosition
1248 instance Eq HandlePosn where
1249 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1251 instance Show HandlePosn where
1252 showsPrec p (HandlePosn h pos) =
1253 showsPrec p h . showString " at position " . shows pos
1255 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1256 -- We represent it as an Integer on the Haskell side, but
1257 -- cheat slightly in that hGetPosn calls upon a C helper
1258 -- that reports the position back via (merely) an Int.
1259 type HandlePosition = Integer
1261 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1262 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1264 hGetPosn :: Handle -> IO HandlePosn
1265 hGetPosn handle = do
1266 posn <- hTell handle
1267 return (HandlePosn handle posn)
1269 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1270 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1271 -- to the position it held at the time of the call to 'hGetPosn'.
1273 -- This operation may fail with:
1275 -- * 'isPermissionError' if a system resource limit would be exceeded.
1277 hSetPosn :: HandlePosn -> IO ()
1278 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1280 -- ---------------------------------------------------------------------------
1283 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1285 = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
1286 | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
1287 -- from the current position.
1288 | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
1289 -- from the end of the file.
1290 deriving (Eq, Ord, Ix, Enum, Read, Show)
1293 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1294 seeking at or past EOF.
1296 - we possibly deviate from the report on the issue of seeking within
1297 the buffer and whether to flush it or not. The report isn't exactly
1301 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1302 -- @hdl@ depending on @mode@.
1303 -- The offset @i@ is given in terms of 8-bit bytes.
1305 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1306 -- in the current buffer will first cause any items in the output buffer to be
1307 -- written to the device, and then cause the input buffer to be discarded.
1308 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1309 -- subset of the possible positioning operations (for instance, it may only
1310 -- be possible to seek to the end of a tape, or to a positive offset from
1311 -- the beginning or current position).
1312 -- It is not possible to set a negative I\/O position, or for
1313 -- a physical file, an I\/O position beyond the current end-of-file.
1315 -- This operation may fail with:
1317 -- * 'isPermissionError' if a system resource limit would be exceeded.
1319 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1320 hSeek handle mode offset =
1321 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1323 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1325 let ref = haBuffer handle_
1326 buf <- readIORef ref
1332 throwErrnoIfMinus1Retry_ "hSeek"
1333 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1336 whence = case mode of
1337 AbsoluteSeek -> sEEK_SET
1338 RelativeSeek -> sEEK_CUR
1339 SeekFromEnd -> sEEK_END
1341 if bufferIsWritable buf
1342 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1343 writeIORef ref new_buf
1347 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1348 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1351 new_buf <- flushReadBuffer (haFD handle_) buf
1352 writeIORef ref new_buf
1356 hTell :: Handle -> IO Integer
1358 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1360 #if defined(mingw32_HOST_OS)
1361 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1362 -- so we can't easily calculate the file position using the
1363 -- current buffer size. Just flush instead.
1366 let fd = fromIntegral (haFD handle_)
1367 posn <- fromIntegral `liftM`
1368 throwErrnoIfMinus1Retry "hGetPosn"
1369 (c_lseek fd 0 sEEK_CUR)
1371 let ref = haBuffer handle_
1372 buf <- readIORef ref
1375 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1376 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1378 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1379 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1383 -- -----------------------------------------------------------------------------
1384 -- Handle Properties
1386 -- A number of operations return information about the properties of a
1387 -- handle. Each of these operations returns `True' if the handle has
1388 -- the specified property, and `False' otherwise.
1390 hIsOpen :: Handle -> IO Bool
1392 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1393 case haType handle_ of
1394 ClosedHandle -> return False
1395 SemiClosedHandle -> return False
1398 hIsClosed :: Handle -> IO Bool
1400 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1401 case haType handle_ of
1402 ClosedHandle -> return True
1405 {- not defined, nor exported, but mentioned
1406 here for documentation purposes:
1408 hSemiClosed :: Handle -> IO Bool
1412 return (not (ho || hc))
1415 hIsReadable :: Handle -> IO Bool
1416 hIsReadable (DuplexHandle _ _ _) = return True
1417 hIsReadable handle =
1418 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1419 case haType handle_ of
1420 ClosedHandle -> ioe_closedHandle
1421 SemiClosedHandle -> ioe_closedHandle
1422 htype -> return (isReadableHandleType htype)
1424 hIsWritable :: Handle -> IO Bool
1425 hIsWritable (DuplexHandle _ _ _) = return True
1426 hIsWritable handle =
1427 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1428 case haType handle_ of
1429 ClosedHandle -> ioe_closedHandle
1430 SemiClosedHandle -> ioe_closedHandle
1431 htype -> return (isWritableHandleType htype)
1433 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1436 hGetBuffering :: Handle -> IO BufferMode
1437 hGetBuffering handle =
1438 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1439 case haType handle_ of
1440 ClosedHandle -> ioe_closedHandle
1442 -- We're being non-standard here, and allow the buffering
1443 -- of a semi-closed handle to be queried. -- sof 6/98
1444 return (haBufferMode handle_) -- could be stricter..
1446 hIsSeekable :: Handle -> IO Bool
1447 hIsSeekable handle =
1448 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1449 case haType handle_ of
1450 ClosedHandle -> ioe_closedHandle
1451 SemiClosedHandle -> ioe_closedHandle
1452 AppendHandle -> return False
1453 _ -> do t <- fdType (haFD handle_)
1454 return (t == RegularFile
1456 || tEXT_MODE_SEEK_ALLOWED))
1458 -- -----------------------------------------------------------------------------
1459 -- Changing echo status (Non-standard GHC extensions)
1461 -- | Set the echoing status of a handle connected to a terminal.
1463 hSetEcho :: Handle -> Bool -> IO ()
1464 hSetEcho handle on = do
1465 isT <- hIsTerminalDevice handle
1469 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1470 case haType handle_ of
1471 ClosedHandle -> ioe_closedHandle
1472 _ -> setEcho (haFD handle_) on
1474 -- | Get the echoing status of a handle connected to a terminal.
1476 hGetEcho :: Handle -> IO Bool
1477 hGetEcho handle = do
1478 isT <- hIsTerminalDevice handle
1482 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1483 case haType handle_ of
1484 ClosedHandle -> ioe_closedHandle
1485 _ -> getEcho (haFD handle_)
1487 -- | Is the handle connected to a terminal?
1489 hIsTerminalDevice :: Handle -> IO Bool
1490 hIsTerminalDevice handle = do
1491 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1492 case haType handle_ of
1493 ClosedHandle -> ioe_closedHandle
1494 _ -> fdIsTTY (haFD handle_)
1496 -- -----------------------------------------------------------------------------
1499 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1500 -- (See also 'openBinaryFile'.)
1502 hSetBinaryMode :: Handle -> Bool -> IO ()
1503 hSetBinaryMode handle bin =
1504 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1505 do throwErrnoIfMinus1_ "hSetBinaryMode"
1506 (setmode (fromIntegral (haFD handle_)) bin)
1507 return handle_{haIsBin=bin}
1509 foreign import ccall unsafe "__hscore_setmode"
1510 setmode :: CInt -> Bool -> IO CInt
1512 -- -----------------------------------------------------------------------------
1513 -- Duplicating a Handle
1515 -- | Returns a duplicate of the original handle, with its own buffer.
1516 -- The two Handles will share a file pointer, however. The original
1517 -- handle's buffer is flushed, including discarding any input data,
1518 -- before the handle is duplicated.
1520 hDuplicate :: Handle -> IO Handle
1521 hDuplicate h@(FileHandle path m) = do
1522 new_h_ <- withHandle' "hDuplicate" h m (dupHandle Nothing)
1523 newFileHandle path (handleFinalizer path) new_h_
1524 hDuplicate h@(DuplexHandle path r w) = do
1525 new_w_ <- withHandle' "hDuplicate" h w (dupHandle Nothing)
1526 new_w <- newMVar new_w_
1527 new_r_ <- withHandle' "hDuplicate" h r (dupHandle (Just new_w))
1528 new_r <- newMVar new_r_
1529 addMVarFinalizer new_w (handleFinalizer path new_w)
1530 return (DuplexHandle path new_r new_w)
1532 dupHandle other_side h_ = do
1533 -- flush the buffer first, so we don't have to copy its contents
1535 new_fd <- throwErrnoIfMinus1 "dupHandle" $
1536 c_dup (fromIntegral (haFD h_))
1537 dupHandle_ other_side h_ new_fd
1539 dupHandleTo other_side h_ hto_ = do
1541 new_fd <- throwErrnoIfMinus1 "dupHandleTo" $
1542 c_dup2 (fromIntegral (haFD hto_)) (fromIntegral (haFD h_))
1543 dupHandle_ other_side h_ new_fd
1545 dupHandle_ other_side h_ new_fd = do
1546 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1547 ioref <- newIORef buffer
1548 ioref_buffers <- newIORef BufferListNil
1550 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1552 haBuffers = ioref_buffers,
1553 haOtherSide = other_side }
1554 return (h_, new_handle_)
1556 -- -----------------------------------------------------------------------------
1557 -- Replacing a Handle
1560 Makes the second handle a duplicate of the first handle. The second
1561 handle will be closed first, if it is not already.
1563 This can be used to retarget the standard Handles, for example:
1565 > do h <- openFile "mystdout" WriteMode
1566 > hDuplicateTo h stdout
1569 hDuplicateTo :: Handle -> Handle -> IO ()
1570 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
1571 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1572 _ <- hClose_help h2_
1573 withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
1574 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
1575 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1576 _ <- hClose_help w2_
1577 withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
1578 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1579 _ <- hClose_help r2_
1580 withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
1582 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1583 "handles are incompatible" Nothing)
1585 -- ---------------------------------------------------------------------------
1588 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1589 -- than the (pure) instance of 'Show' for 'Handle'.
1591 hShow :: Handle -> IO String
1592 hShow h@(FileHandle path _) = showHandle' path False h
1593 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1595 showHandle' filepath is_duplex h =
1596 withHandle_ "showHandle" h $ \hdl_ ->
1598 showType | is_duplex = showString "duplex (read-write)"
1599 | otherwise = shows (haType hdl_)
1603 showHdl (haType hdl_)
1604 (showString "loc=" . showString filepath . showChar ',' .
1605 showString "type=" . showType . showChar ',' .
1606 showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1607 showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1611 showHdl :: HandleType -> ShowS -> ShowS
1614 ClosedHandle -> shows ht . showString "}"
1617 showBufMode :: Buffer -> BufferMode -> ShowS
1618 showBufMode buf bmo =
1620 NoBuffering -> showString "none"
1621 LineBuffering -> showString "line"
1622 BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1623 BlockBuffering Nothing -> showString "block " . showParen True (shows def)
1628 -- ---------------------------------------------------------------------------
1632 puts :: String -> IO ()
1633 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1637 -- -----------------------------------------------------------------------------
1640 throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
1641 throwErrnoIfMinus1RetryOnBlock loc f on_block =
1644 if (res :: CInt) == -1
1648 then throwErrnoIfMinus1RetryOnBlock loc f on_block
1649 else if err == eWOULDBLOCK || err == eAGAIN
1654 -- -----------------------------------------------------------------------------
1655 -- wrappers to platform-specific constants:
1657 foreign import ccall unsafe "__hscore_supportsTextMode"
1658 tEXT_MODE_SEEK_ALLOWED :: Bool
1660 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1661 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1662 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1663 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt