1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
6 -----------------------------------------------------------------------------
9 -- Copyright : (c) The University of Glasgow, 1994-2001
10 -- License : see libraries/base/LICENSE
12 -- Maintainer : libraries@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable
16 -- This module defines the basic operations on I\/O \"handles\".
18 -----------------------------------------------------------------------------
21 withHandle, withHandle', withHandle_,
22 wantWritableHandle, wantReadableHandle, wantSeekableHandle,
24 newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
25 flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
26 fillReadBuffer, fillReadBufferWithoutBlocking,
27 readRawBuffer, readRawBufferPtr,
28 writeRawBuffer, writeRawBufferPtr,
31 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
33 stdin, stdout, stderr,
34 IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
35 hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
36 hFlush, hDuplicate, hDuplicateTo,
40 HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
41 SeekMode(..), hSeek, hTell,
43 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
44 hSetEcho, hGetEcho, hIsTerminalDevice,
54 #include "ghcconfig.h"
61 import System.IO.Error
62 import System.Posix.Internals
68 import GHC.Read ( Read )
73 import GHC.Num ( Integer(..), Num(..) )
75 import GHC.Real ( toInteger )
79 -- -----------------------------------------------------------------------------
82 -- hWaitForInput blocks (should use a timeout)
84 -- unbuffered hGetLine is a bit dodgy
86 -- hSetBuffering: can't change buffering on a stream,
87 -- when the read buffer is non-empty? (no way to flush the buffer)
89 -- ---------------------------------------------------------------------------
90 -- Are files opened by default in text or binary mode, if the user doesn't
93 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
95 -- ---------------------------------------------------------------------------
96 -- Creating a new handle
98 newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
99 newFileHandle filepath finalizer hc = do
101 addMVarFinalizer m (finalizer m)
102 return (FileHandle filepath m)
104 -- ---------------------------------------------------------------------------
105 -- Working with Handles
108 In the concurrent world, handles are locked during use. This is done
109 by wrapping an MVar around the handle which acts as a mutex over
110 operations on the handle.
112 To avoid races, we use the following bracketing operations. The idea
113 is to obtain the lock, do some operation and replace the lock again,
114 whether the operation succeeded or failed. We also want to handle the
115 case where the thread receives an exception while processing the IO
116 operation: in these cases we also want to relinquish the lock.
118 There are three versions of @withHandle@: corresponding to the three
119 possible combinations of:
121 - the operation may side-effect the handle
122 - the operation may return a result
124 If the operation generates an error or an exception is raised, the
125 original handle is always replaced [ this is the case at the moment,
126 but we might want to revisit this in the future --SDM ].
129 {-# INLINE withHandle #-}
130 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
131 withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
132 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
134 withHandle' :: String -> Handle -> MVar Handle__
135 -> (Handle__ -> IO (Handle__,a)) -> IO a
136 withHandle' fun h m act =
139 checkBufferInvariants h_
140 (h',v) <- catchException (act h_)
141 (\ err -> putMVar m h_ >>
143 IOException ex -> ioError (augmentIOError ex fun h)
145 checkBufferInvariants h'
149 {-# INLINE withHandle_ #-}
150 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
151 withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
152 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
154 withHandle_' fun h m act =
157 checkBufferInvariants h_
158 v <- catchException (act h_)
159 (\ err -> putMVar m h_ >>
161 IOException ex -> ioError (augmentIOError ex fun h)
163 checkBufferInvariants h_
167 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
168 withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
169 withAllHandles__ fun h@(DuplexHandle _ r w) act = do
170 withHandle__' fun h r act
171 withHandle__' fun h w act
173 withHandle__' fun h m act =
176 checkBufferInvariants h_
177 h' <- catchException (act h_)
178 (\ err -> putMVar m h_ >>
180 IOException ex -> ioError (augmentIOError ex fun h)
182 checkBufferInvariants h'
186 augmentIOError (IOError _ iot _ str fp) fun h
187 = IOError (Just h) iot fun str filepath
190 | otherwise = case h of
191 FileHandle fp _ -> Just fp
192 DuplexHandle fp _ _ -> Just fp
194 -- ---------------------------------------------------------------------------
195 -- Wrapper for write operations.
197 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
198 wantWritableHandle fun h@(FileHandle _ m) act
199 = wantWritableHandle' fun h m act
200 wantWritableHandle fun h@(DuplexHandle _ _ m) act
201 = wantWritableHandle' fun h m act
202 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
205 :: String -> Handle -> MVar Handle__
206 -> (Handle__ -> IO a) -> IO a
207 wantWritableHandle' fun h m act
208 = withHandle_' fun h m (checkWritableHandle act)
210 checkWritableHandle act handle_
211 = case haType handle_ of
212 ClosedHandle -> ioe_closedHandle
213 SemiClosedHandle -> ioe_closedHandle
214 ReadHandle -> ioe_notWritable
215 ReadWriteHandle -> do
216 let ref = haBuffer handle_
219 if not (bufferIsWritable buf)
220 then do b <- flushReadBuffer (haFD handle_) buf
221 return b{ bufState=WriteBuffer }
223 writeIORef ref new_buf
225 _other -> act handle_
227 -- ---------------------------------------------------------------------------
228 -- Wrapper for read operations.
230 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
231 wantReadableHandle fun h@(FileHandle _ m) act
232 = wantReadableHandle' fun h m act
233 wantReadableHandle fun h@(DuplexHandle _ m _) act
234 = wantReadableHandle' fun h m act
235 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
238 :: String -> Handle -> MVar Handle__
239 -> (Handle__ -> IO a) -> IO a
240 wantReadableHandle' fun h m act
241 = withHandle_' fun h m (checkReadableHandle act)
243 checkReadableHandle act handle_ =
244 case haType handle_ of
245 ClosedHandle -> ioe_closedHandle
246 SemiClosedHandle -> ioe_closedHandle
247 AppendHandle -> ioe_notReadable
248 WriteHandle -> ioe_notReadable
249 ReadWriteHandle -> do
250 let ref = haBuffer handle_
252 when (bufferIsWritable buf) $ do
253 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
254 writeIORef ref new_buf{ bufState=ReadBuffer }
256 _other -> act handle_
258 -- ---------------------------------------------------------------------------
259 -- Wrapper for seek operations.
261 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
262 wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
263 ioException (IOError (Just h) IllegalOperation fun
264 "handle is not seekable" Nothing)
265 wantSeekableHandle fun h@(FileHandle _ m) act =
266 withHandle_' fun h m (checkSeekableHandle act)
268 checkSeekableHandle act handle_ =
269 case haType handle_ of
270 ClosedHandle -> ioe_closedHandle
271 SemiClosedHandle -> ioe_closedHandle
272 AppendHandle -> ioe_notSeekable
273 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
274 | otherwise -> ioe_notSeekable_notBin
276 -- -----------------------------------------------------------------------------
279 ioe_closedHandle, ioe_EOF,
280 ioe_notReadable, ioe_notWritable,
281 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
283 ioe_closedHandle = ioException
284 (IOError Nothing IllegalOperation ""
285 "handle is closed" Nothing)
286 ioe_EOF = ioException
287 (IOError Nothing EOF "" "" Nothing)
288 ioe_notReadable = ioException
289 (IOError Nothing IllegalOperation ""
290 "handle is not open for reading" Nothing)
291 ioe_notWritable = ioException
292 (IOError Nothing IllegalOperation ""
293 "handle is not open for writing" Nothing)
294 ioe_notSeekable = ioException
295 (IOError Nothing IllegalOperation ""
296 "handle is not seekable" Nothing)
297 ioe_notSeekable_notBin = ioException
298 (IOError Nothing IllegalOperation ""
299 "seek operations on text-mode handles are not allowed on this platform"
302 ioe_finalizedHandle fp = throw (IOException
303 (IOError Nothing IllegalOperation ""
304 "handle is finalized" (Just fp)))
306 ioe_bufsiz :: Int -> IO a
307 ioe_bufsiz n = ioException
308 (IOError Nothing InvalidArgument "hSetBuffering"
309 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
310 -- 9 => should be parens'ified.
312 -- -----------------------------------------------------------------------------
315 -- For a duplex handle, we arrange that the read side points to the write side
316 -- (and hence keeps it alive if the read side is alive). This is done by
317 -- having the haOtherSide field of the read side point to the read side.
318 -- The finalizer is then placed on the write side, and the handle only gets
319 -- finalized once, when both sides are no longer required.
321 -- NOTE about finalized handles: It's possible that a handle can be
322 -- finalized and then we try to use it later, for example if the
323 -- handle is referenced from another finalizer, or from a thread that
324 -- has become unreferenced and then resurrected (arguably in the
325 -- latter case we shouldn't finalize the Handle...). Anyway,
326 -- we try to emit a helpful message which is better than nothing.
328 stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
329 stdHandleFinalizer fp m = do
331 flushWriteBufferOnly h_
332 putMVar m (ioe_finalizedHandle fp)
334 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
335 handleFinalizer fp m = do
336 handle_ <- takeMVar m
337 case haType handle_ of
338 ClosedHandle -> return ()
339 _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
340 -- ignore errors and async exceptions, and close the
341 -- descriptor anyway...
342 hClose_handle_ handle_
344 putMVar m (ioe_finalizedHandle fp)
346 -- ---------------------------------------------------------------------------
347 -- Grimy buffer operations
350 checkBufferInvariants h_ = do
351 let ref = haBuffer h_
352 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
357 && ( r /= w || (r == 0 && w == 0) )
358 && ( state /= WriteBuffer || r == 0 )
359 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
361 then error "buffer invariant violation"
364 checkBufferInvariants h_ = return ()
367 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
368 newEmptyBuffer b state size
369 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
371 allocateBuffer :: Int -> BufferState -> IO Buffer
372 allocateBuffer sz@(I# size) state = IO $ \s ->
373 #ifdef mingw32_TARGET_OS
374 -- To implement asynchronous I/O under Win32, we have to pass
375 -- buffer references to external threads that handles the
376 -- filling/emptying of their contents. Hence, the buffer cannot
377 -- be moved around by the GC.
378 case newPinnedByteArray# size s of { (# s, b #) ->
380 case newByteArray# size s of { (# s, b #) ->
382 (# s, newEmptyBuffer b state sz #) }
384 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
385 writeCharIntoBuffer slab (I# off) (C# c)
386 = IO $ \s -> case writeCharArray# slab off c s of
387 s -> (# s, I# (off +# 1#) #)
389 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
390 readCharFromBuffer slab (I# off)
391 = IO $ \s -> case readCharArray# slab off s of
392 (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
394 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
395 getBuffer fd state = do
396 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
397 ioref <- newIORef buffer
401 | is_tty = LineBuffering
402 | otherwise = BlockBuffering Nothing
404 return (ioref, buffer_mode)
406 mkUnBuffer :: IO (IORef Buffer)
408 buffer <- allocateBuffer 1 ReadBuffer
411 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
412 flushWriteBufferOnly :: Handle__ -> IO ()
413 flushWriteBufferOnly h_ = do
417 new_buf <- if bufferIsWritable buf
418 then flushWriteBuffer fd (haIsStream h_) buf
420 writeIORef ref new_buf
422 -- flushBuffer syncs the file with the buffer, including moving the
423 -- file pointer backwards in the case of a read buffer.
424 flushBuffer :: Handle__ -> IO ()
426 let ref = haBuffer h_
431 ReadBuffer -> flushReadBuffer (haFD h_) buf
432 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
434 writeIORef ref flushed_buf
436 -- When flushing a read buffer, we seek backwards by the number of
437 -- characters in the buffer. The file descriptor must therefore be
438 -- seekable: attempting to flush the read buffer on an unseekable
439 -- handle is not allowed.
441 flushReadBuffer :: FD -> Buffer -> IO Buffer
442 flushReadBuffer fd buf
443 | bufferEmpty buf = return buf
445 let off = negate (bufWPtr buf - bufRPtr buf)
447 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
449 throwErrnoIfMinus1Retry "flushReadBuffer"
450 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
451 return buf{ bufWPtr=0, bufRPtr=0 }
453 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
454 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
455 seq fd $ do -- strictness hack
458 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
461 then return (buf{ bufRPtr=0, bufWPtr=0 })
463 res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
464 (fromIntegral r) (fromIntegral bytes)
465 let res' = fromIntegral res
467 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
468 else return buf{ bufRPtr=0, bufWPtr=0 }
470 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
471 fillReadBuffer fd is_line is_stream
472 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
473 -- buffer better be empty:
474 assert (r == 0 && w == 0) $ do
475 fillReadBufferLoop fd is_line is_stream buf b w size
477 -- For a line buffer, we just get the first chunk of data to arrive,
478 -- and don't wait for the whole buffer to be full (but we *do* wait
479 -- until some data arrives). This isn't really line buffering, but it
480 -- appears to be what GHC has done for a long time, and I suspect it
481 -- is more useful than line buffering in most cases.
483 fillReadBufferLoop fd is_line is_stream buf b w size = do
485 if bytes == 0 -- buffer full?
486 then return buf{ bufRPtr=0, bufWPtr=w }
489 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
491 res <- readRawBuffer "fillReadBuffer" fd is_stream b
492 (fromIntegral w) (fromIntegral bytes)
493 let res' = fromIntegral res
495 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
500 else return buf{ bufRPtr=0, bufWPtr=w }
501 else if res' < bytes && not is_line
502 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
503 else return buf{ bufRPtr=0, bufWPtr=w+res' }
506 fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
507 fillReadBufferWithoutBlocking fd is_stream
508 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
509 -- buffer better be empty:
510 assert (r == 0 && w == 0) $ do
512 puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
514 res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
515 0 (fromIntegral size)
516 let res' = fromIntegral res
518 puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
520 return buf{ bufRPtr=0, bufWPtr=res' }
522 -- Low level routines for reading/writing to (raw)buffers:
524 #ifndef mingw32_TARGET_OS
525 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
526 readRawBuffer loc fd is_stream buf off len =
527 throwErrnoIfMinus1RetryMayBlock loc
528 (read_rawBuffer fd buf off len)
529 (threadWaitRead (fromIntegral fd))
531 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
532 readRawBufferNoBlock loc fd is_stream buf off len =
533 throwErrnoIfMinus1RetryOnBlock loc
534 (read_rawBuffer fd buf off len)
537 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
538 readRawBufferPtr loc fd is_stream buf off len =
539 throwErrnoIfMinus1RetryMayBlock loc
540 (read_off fd buf off len)
541 (threadWaitRead (fromIntegral fd))
543 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
544 writeRawBuffer loc fd is_stream buf off len =
545 throwErrnoIfMinus1RetryMayBlock loc
546 (write_rawBuffer (fromIntegral fd) buf off len)
547 (threadWaitWrite (fromIntegral fd))
549 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
550 writeRawBufferPtr loc fd is_stream buf off len =
551 throwErrnoIfMinus1RetryMayBlock loc
552 (write_off (fromIntegral fd) buf off len)
553 (threadWaitWrite (fromIntegral fd))
555 foreign import ccall unsafe "__hscore_PrelHandle_read"
556 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
558 foreign import ccall unsafe "__hscore_PrelHandle_read"
559 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
561 foreign import ccall unsafe "__hscore_PrelHandle_write"
562 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
564 foreign import ccall unsafe "__hscore_PrelHandle_write"
565 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
567 #else /* mingw32_TARGET_OS.... */
569 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
570 readRawBuffer loc fd is_stream buf off len
571 | threaded = blockingReadRawBuffer loc fd is_stream buf off len
572 | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
574 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
575 readRawBufferPtr loc fd is_stream buf off len
576 | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
577 | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
579 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
580 writeRawBuffer loc fd is_stream buf off len
581 | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
582 | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
584 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
585 writeRawBufferPtr loc fd is_stream buf off len
586 | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
587 | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len
589 -- ToDo: we don't have a non-blocking primitve read on Win32
590 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
591 readRawBufferNoBlock = readRawBufferNoBlock
593 -- Async versions of the read/write primitives, for the non-threaded RTS
595 asyncReadRawBuffer loc fd is_stream buf off len = do
596 (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0)
597 (fromIntegral len) off buf
600 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
601 else return (fromIntegral l)
603 asyncReadRawBufferPtr loc fd is_stream buf off len = do
604 (l, rc) <- asyncRead fd (if is_stream then 1 else 0)
605 (fromIntegral len) (buf `plusPtr` off)
608 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
609 else return (fromIntegral l)
611 asyncWriteRawBuffer loc fd is_stream buf off len = do
612 (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0)
613 (fromIntegral len) off buf
616 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
617 else return (fromIntegral l)
619 asyncWriteRawBufferPtr loc fd is_stream buf off len = do
620 (l, rc) <- asyncWrite fd (if is_stream then 1 else 0)
621 (fromIntegral len) (buf `plusPtr` off)
624 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
625 else return (fromIntegral l)
627 -- Blocking versions of the read/write primitives, for the threaded RTS
629 blockingReadRawBuffer loc fd True buf off len =
630 throwErrnoIfMinus1Retry loc $
631 recv_rawBuffer fd buf off len
632 blockingReadRawBuffer loc fd False buf off len =
633 throwErrnoIfMinus1Retry loc $
634 read_rawBuffer fd buf off len
636 blockingReadRawBufferPtr loc fd True buf off len =
637 throwErrnoIfMinus1Retry loc $
638 recv_off fd buf off len
639 blockingReadRawBufferPtr loc fd False buf off len =
640 throwErrnoIfMinus1Retry loc $
641 read_off fd buf off len
643 blockingWriteRawBuffer loc fd True buf off len =
644 throwErrnoIfMinus1Retry loc $
645 send_rawBuffer (fromIntegral fd) buf off len
646 blockingWriteRawBuffer loc fd False buf off len =
647 throwErrnoIfMinus1Retry loc $
648 write_rawBuffer (fromIntegral fd) buf off len
650 blockingWriteRawBufferPtr loc fd True buf off len =
651 throwErrnoIfMinus1Retry loc $
652 send_off (fromIntegral fd) buf off len
653 blockingWriteRawBufferPtr loc fd False buf off len =
654 throwErrnoIfMinus1Retry loc $
655 write_off (fromIntegral fd) buf off len
657 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
658 -- These calls may block, but that's ok.
660 foreign import ccall safe "__hscore_PrelHandle_read"
661 read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
663 foreign import ccall safe "__hscore_PrelHandle_read"
664 read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
666 foreign import ccall safe "__hscore_PrelHandle_write"
667 write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
669 foreign import ccall safe "__hscore_PrelHandle_write"
670 write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
672 foreign import ccall safe "__hscore_PrelHandle_recv"
673 recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
675 foreign import ccall safe "__hscore_PrelHandle_recv"
676 recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
678 foreign import ccall safe "__hscore_PrelHandle_send"
679 send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
681 foreign import ccall safe "__hscore_PrelHandle_send"
682 send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
684 foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
687 -- ---------------------------------------------------------------------------
690 -- Three handles are allocated during program initialisation. The first
691 -- two manage input or output from the Haskell program's standard input
692 -- or output channel respectively. The third manages output to the
693 -- standard error channel. These handles are initially open.
699 -- | A handle managing input from the Haskell program's standard input channel.
701 stdin = unsafePerformIO $ do
702 -- ToDo: acquire lock
703 setNonBlockingFD fd_stdin
704 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
705 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
707 -- | A handle managing output to the Haskell program's standard output channel.
709 stdout = unsafePerformIO $ do
710 -- ToDo: acquire lock
711 -- We don't set non-blocking mode on stdout or sterr, because
712 -- some shells don't recover properly.
713 -- setNonBlockingFD fd_stdout
714 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
715 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
717 -- | A handle managing output to the Haskell program's standard error channel.
719 stderr = unsafePerformIO $ do
720 -- ToDo: acquire lock
721 -- We don't set non-blocking mode on stdout or sterr, because
722 -- some shells don't recover properly.
723 -- setNonBlockingFD fd_stderr
725 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
727 -- ---------------------------------------------------------------------------
728 -- Opening and Closing Files
730 addFilePathToIOError fun fp (IOError h iot _ str _)
731 = IOError h iot fun str (Just fp)
733 -- | Computation 'openFile' @file mode@ allocates and returns a new, open
734 -- handle to manage the file @file@. It manages input if @mode@
735 -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
736 -- and both input and output if mode is 'ReadWriteMode'.
738 -- If the file does not exist and it is opened for output, it should be
739 -- created as a new file. If @mode@ is 'WriteMode' and the file
740 -- already exists, then it should be truncated to zero length.
741 -- Some operating systems delete empty files, so there is no guarantee
742 -- that the file will exist following an 'openFile' with @mode@
743 -- 'WriteMode' unless it is subsequently written to successfully.
744 -- The handle is positioned at the end of the file if @mode@ is
745 -- 'AppendMode', and otherwise at the beginning (in which case its
746 -- internal position is 0).
747 -- The initial buffer mode is implementation-dependent.
749 -- This operation may fail with:
751 -- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
753 -- * 'isDoesNotExistError' if the file does not exist; or
755 -- * 'isPermissionError' if the user does not have permission to open the file.
757 -- Note: if you will be working with files containing binary data, you'll want to
758 -- be using 'openBinaryFile'.
759 openFile :: FilePath -> IOMode -> IO Handle
762 (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
763 (\e -> ioError (addFilePathToIOError "openFile" fp e))
765 -- | Like 'openFile', but open the file in binary mode.
766 -- On Windows, reading a file in text mode (which is the default)
767 -- will translate CRLF to LF, and writing will translate LF to CRLF.
768 -- This is usually what you want with text files. With binary files
769 -- this is undesirable; also, as usual under Microsoft operating systems,
770 -- text mode treats control-Z as EOF. Binary mode turns off all special
771 -- treatment of end-of-line and end-of-file characters.
772 -- (See also 'hSetBinaryMode'.)
774 openBinaryFile :: FilePath -> IOMode -> IO Handle
775 openBinaryFile fp m =
777 (openFile' fp m True)
778 (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
780 openFile' filepath mode binary =
781 withCString filepath $ \ f ->
784 oflags1 = case mode of
785 ReadMode -> read_flags
786 WriteMode -> write_flags
787 ReadWriteMode -> rw_flags
788 AppendMode -> append_flags
790 truncate | WriteMode <- mode = True
797 oflags = oflags1 .|. binary_flags
800 -- the old implementation had a complicated series of three opens,
801 -- which is perhaps because we have to be careful not to open
802 -- directories. However, the man pages I've read say that open()
803 -- always returns EISDIR if the file is a directory and was opened
804 -- for writing, so I think we're ok with a single open() here...
805 fd <- fromIntegral `liftM`
806 throwErrnoIfMinus1Retry "openFile"
807 (c_open f (fromIntegral oflags) 0o666)
809 openFd fd Nothing False filepath mode binary truncate
810 `catchException` \e -> do c_close (fromIntegral fd); throw e
811 -- NB. don't forget to close the FD if openFd fails, otherwise
813 -- ASSERT: if we just created the file, then openFd won't fail
814 -- (so we don't need to worry about removing the newly created file
815 -- in the event of an error).
818 std_flags = o_NONBLOCK .|. o_NOCTTY
819 output_flags = std_flags .|. o_CREAT
820 read_flags = std_flags .|. o_RDONLY
821 write_flags = output_flags .|. o_WRONLY
822 rw_flags = output_flags .|. o_RDWR
823 append_flags = write_flags .|. o_APPEND
825 -- ---------------------------------------------------------------------------
828 openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
829 openFd fd mb_fd_type is_socket filepath mode binary truncate = do
830 -- turn on non-blocking mode
833 let (ha_type, write) =
835 ReadMode -> ( ReadHandle, False )
836 WriteMode -> ( WriteHandle, True )
837 ReadWriteMode -> ( ReadWriteHandle, True )
838 AppendMode -> ( AppendHandle, True )
840 -- open() won't tell us if it was a directory if we only opened for
841 -- reading, so check again.
849 ioException (IOError Nothing InappropriateType "openFile"
850 "is a directory" Nothing)
853 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
854 | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
856 -- regular files need to be locked
858 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
860 ioException (IOError Nothing ResourceBusy "openFile"
861 "file is locked" Nothing)
863 -- truncate the file if necessary
864 when truncate (fileTruncate filepath)
866 mkFileHandle fd is_socket filepath ha_type binary
869 fdToHandle :: FD -> IO Handle
872 let fd_str = "<file descriptor: " ++ show fd ++ ">"
873 openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} False{-no truncate-}
875 foreign import ccall unsafe "lockFile"
876 lockFile :: CInt -> CInt -> CInt -> IO CInt
878 foreign import ccall unsafe "unlockFile"
879 unlockFile :: CInt -> IO CInt
881 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
883 mkStdHandle fd filepath ha_type buf bmode = do
884 spares <- newIORef BufferListNil
885 newFileHandle filepath (stdHandleFinalizer filepath)
886 (Handle__ { haFD = fd,
888 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
890 haBufferMode = bmode,
893 haOtherSide = Nothing
896 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
897 mkFileHandle fd is_stream filepath ha_type binary = do
898 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
899 spares <- newIORef BufferListNil
900 newFileHandle filepath (handleFinalizer filepath)
901 (Handle__ { haFD = fd,
904 haIsStream = is_stream,
905 haBufferMode = bmode,
908 haOtherSide = Nothing
911 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
912 mkDuplexHandle fd is_stream filepath binary = do
913 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
914 w_spares <- newIORef BufferListNil
916 Handle__ { haFD = fd,
917 haType = WriteHandle,
919 haIsStream = is_stream,
920 haBufferMode = w_bmode,
922 haBuffers = w_spares,
923 haOtherSide = Nothing
925 write_side <- newMVar w_handle_
927 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
928 r_spares <- newIORef BufferListNil
930 Handle__ { haFD = fd,
933 haIsStream = is_stream,
934 haBufferMode = r_bmode,
936 haBuffers = r_spares,
937 haOtherSide = Just write_side
939 read_side <- newMVar r_handle_
941 addMVarFinalizer write_side (handleFinalizer filepath write_side)
942 return (DuplexHandle filepath read_side write_side)
945 initBufferState ReadHandle = ReadBuffer
946 initBufferState _ = WriteBuffer
948 -- ---------------------------------------------------------------------------
951 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
952 -- computation finishes, if @hdl@ is writable its buffer is flushed as
954 -- Performing 'hClose' on a handle that has already been closed has no effect;
955 -- doing so not an error. All other operations on a closed handle will fail.
956 -- If 'hClose' fails for any reason, any further operations (apart from
957 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
960 hClose :: Handle -> IO ()
961 hClose h@(FileHandle _ m) = hClose' h m
962 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
964 hClose' h m = withHandle__' "hClose" h m $ hClose_help
966 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
967 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
968 -- then closed immediately. We have to be careful with DuplexHandles
969 -- though: we have to leave the closing to the finalizer in that case,
970 -- because the write side may still be in use.
971 hClose_help :: Handle__ -> IO Handle__
972 hClose_help handle_ =
973 case haType handle_ of
974 ClosedHandle -> return handle_
975 _ -> do flushWriteBufferOnly handle_ -- interruptible
976 hClose_handle_ handle_
978 hClose_handle_ handle_ = do
979 let fd = haFD handle_
980 c_fd = fromIntegral fd
982 -- close the file descriptor, but not when this is the read
983 -- side of a duplex handle, and not when this is one of the
985 case haOtherSide handle_ of
987 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
988 throwErrnoIfMinus1Retry_ "hClose"
989 #ifdef mingw32_TARGET_OS
990 (closeFd (haIsStream handle_) c_fd)
996 -- free the spare buffers
997 writeIORef (haBuffers handle_) BufferListNil
1002 -- we must set the fd to -1, because the finalizer is going
1003 -- to run eventually and try to close/unlock it.
1004 return (handle_{ haFD = -1,
1005 haType = ClosedHandle
1008 -----------------------------------------------------------------------------
1009 -- Detecting the size of a file
1011 -- | For a handle @hdl@ which attached to a physical file,
1012 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
1014 hFileSize :: Handle -> IO Integer
1016 withHandle_ "hFileSize" handle $ \ handle_ -> do
1017 case haType handle_ of
1018 ClosedHandle -> ioe_closedHandle
1019 SemiClosedHandle -> ioe_closedHandle
1020 _ -> do flushWriteBufferOnly handle_
1021 r <- fdFileSize (haFD handle_)
1024 else ioException (IOError Nothing InappropriateType "hFileSize"
1025 "not a regular file" Nothing)
1027 -- ---------------------------------------------------------------------------
1028 -- Detecting the End of Input
1030 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
1031 -- 'True' if no further input can be taken from @hdl@ or for a
1032 -- physical file, if the current I\/O position is equal to the length of
1033 -- the file. Otherwise, it returns 'False'.
1035 hIsEOF :: Handle -> IO Bool
1038 (do hLookAhead handle; return False)
1039 (\e -> if isEOFError e then return True else ioError e)
1041 -- | The computation 'isEOF' is identical to 'hIsEOF',
1042 -- except that it works only on 'stdin'.
1045 isEOF = hIsEOF stdin
1047 -- ---------------------------------------------------------------------------
1050 -- | Computation 'hLookAhead' returns the next character from the handle
1051 -- without removing it from the input buffer, blocking until a character
1054 -- This operation may fail with:
1056 -- * 'isEOFError' if the end of file has been reached.
1058 hLookAhead :: Handle -> IO Char
1059 hLookAhead handle = do
1060 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
1061 let ref = haBuffer handle_
1063 is_line = haBufferMode handle_ == LineBuffering
1064 buf <- readIORef ref
1066 -- fill up the read buffer if necessary
1067 new_buf <- if bufferEmpty buf
1068 then fillReadBuffer fd is_line (haIsStream handle_) buf
1071 writeIORef ref new_buf
1073 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
1076 -- ---------------------------------------------------------------------------
1077 -- Buffering Operations
1079 -- Three kinds of buffering are supported: line-buffering,
1080 -- block-buffering or no-buffering. See GHC.IOBase for definition and
1081 -- further explanation of what the type represent.
1083 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
1084 -- handle @hdl@ on subsequent reads and writes.
1086 -- If the buffer mode is changed from 'BlockBuffering' or
1087 -- 'LineBuffering' to 'NoBuffering', then
1089 -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
1091 -- * if @hdl@ is not writable, the contents of the buffer is discarded.
1093 -- This operation may fail with:
1095 -- * 'isPermissionError' if the handle has already been used for reading
1096 -- or writing and the implementation does not allow the buffering mode
1099 hSetBuffering :: Handle -> BufferMode -> IO ()
1100 hSetBuffering handle mode =
1101 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
1102 case haType handle_ of
1103 ClosedHandle -> ioe_closedHandle
1106 - we flush the old buffer regardless of whether
1107 the new buffer could fit the contents of the old buffer
1109 - allow a handle's buffering to change even if IO has
1110 occurred (ANSI C spec. does not allow this, nor did
1111 the previous implementation of IO.hSetBuffering).
1112 - a non-standard extension is to allow the buffering
1113 of semi-closed handles to change [sof 6/98]
1117 let state = initBufferState (haType handle_)
1120 -- we always have a 1-character read buffer for
1121 -- unbuffered handles: it's needed to
1122 -- support hLookAhead.
1123 NoBuffering -> allocateBuffer 1 ReadBuffer
1124 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
1125 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1126 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
1127 | otherwise -> allocateBuffer n state
1128 writeIORef (haBuffer handle_) new_buf
1130 -- for input terminals we need to put the terminal into
1131 -- cooked or raw mode depending on the type of buffering.
1132 is_tty <- fdIsTTY (haFD handle_)
1133 when (is_tty && isReadableHandleType (haType handle_)) $
1135 #ifndef mingw32_TARGET_OS
1136 -- 'raw' mode under win32 is a bit too specialised (and troublesome
1137 -- for most common uses), so simply disable its use here.
1138 NoBuffering -> setCooked (haFD handle_) False
1140 _ -> setCooked (haFD handle_) True
1142 -- throw away spare buffers, they might be the wrong size
1143 writeIORef (haBuffers handle_) BufferListNil
1145 return (handle_{ haBufferMode = mode })
1147 -- -----------------------------------------------------------------------------
1150 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1151 -- in handle @hdl@ to be sent immediately to the operating system.
1153 -- This operation may fail with:
1155 -- * 'isFullError' if the device is full;
1157 -- * 'isPermissionError' if a system resource limit would be exceeded.
1158 -- It is unspecified whether the characters in the buffer are discarded
1159 -- or retained under these circumstances.
1161 hFlush :: Handle -> IO ()
1163 wantWritableHandle "hFlush" handle $ \ handle_ -> do
1164 buf <- readIORef (haBuffer handle_)
1165 if bufferIsWritable buf && not (bufferEmpty buf)
1166 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1167 writeIORef (haBuffer handle_) flushed_buf
1171 -- -----------------------------------------------------------------------------
1172 -- Repositioning Handles
1174 data HandlePosn = HandlePosn Handle HandlePosition
1176 instance Eq HandlePosn where
1177 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1179 instance Show HandlePosn where
1180 showsPrec p (HandlePosn h pos) =
1181 showsPrec p h . showString " at position " . shows pos
1183 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1184 -- We represent it as an Integer on the Haskell side, but
1185 -- cheat slightly in that hGetPosn calls upon a C helper
1186 -- that reports the position back via (merely) an Int.
1187 type HandlePosition = Integer
1189 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1190 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1192 hGetPosn :: Handle -> IO HandlePosn
1193 hGetPosn handle = do
1194 posn <- hTell handle
1195 return (HandlePosn handle posn)
1197 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1198 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1199 -- to the position it held at the time of the call to 'hGetPosn'.
1201 -- This operation may fail with:
1203 -- * 'isPermissionError' if a system resource limit would be exceeded.
1205 hSetPosn :: HandlePosn -> IO ()
1206 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1208 -- ---------------------------------------------------------------------------
1211 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1213 = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
1214 | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
1215 -- from the current position.
1216 | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
1217 -- from the end of the file.
1218 deriving (Eq, Ord, Ix, Enum, Read, Show)
1221 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1222 seeking at or past EOF.
1224 - we possibly deviate from the report on the issue of seeking within
1225 the buffer and whether to flush it or not. The report isn't exactly
1229 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1230 -- @hdl@ depending on @mode@.
1231 -- The offset @i@ is given in terms of 8-bit bytes.
1233 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1234 -- in the current buffer will first cause any items in the output buffer to be
1235 -- written to the device, and then cause the input buffer to be discarded.
1236 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1237 -- subset of the possible positioning operations (for instance, it may only
1238 -- be possible to seek to the end of a tape, or to a positive offset from
1239 -- the beginning or current position).
1240 -- It is not possible to set a negative I\/O position, or for
1241 -- a physical file, an I\/O position beyond the current end-of-file.
1243 -- This operation may fail with:
1245 -- * 'isPermissionError' if a system resource limit would be exceeded.
1247 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1248 hSeek handle mode offset =
1249 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1251 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1253 let ref = haBuffer handle_
1254 buf <- readIORef ref
1260 throwErrnoIfMinus1Retry_ "hSeek"
1261 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1264 whence = case mode of
1265 AbsoluteSeek -> sEEK_SET
1266 RelativeSeek -> sEEK_CUR
1267 SeekFromEnd -> sEEK_END
1269 if bufferIsWritable buf
1270 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1271 writeIORef ref new_buf
1275 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1276 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1279 new_buf <- flushReadBuffer (haFD handle_) buf
1280 writeIORef ref new_buf
1284 hTell :: Handle -> IO Integer
1286 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1288 #if defined(mingw32_TARGET_OS)
1289 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1290 -- so we can't easily calculate the file position using the
1291 -- current buffer size. Just flush instead.
1294 let fd = fromIntegral (haFD handle_)
1295 posn <- fromIntegral `liftM`
1296 throwErrnoIfMinus1Retry "hGetPosn"
1297 (c_lseek fd 0 sEEK_CUR)
1299 let ref = haBuffer handle_
1300 buf <- readIORef ref
1303 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1304 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1306 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1307 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1311 -- -----------------------------------------------------------------------------
1312 -- Handle Properties
1314 -- A number of operations return information about the properties of a
1315 -- handle. Each of these operations returns `True' if the handle has
1316 -- the specified property, and `False' otherwise.
1318 hIsOpen :: Handle -> IO Bool
1320 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1321 case haType handle_ of
1322 ClosedHandle -> return False
1323 SemiClosedHandle -> return False
1326 hIsClosed :: Handle -> IO Bool
1328 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1329 case haType handle_ of
1330 ClosedHandle -> return True
1333 {- not defined, nor exported, but mentioned
1334 here for documentation purposes:
1336 hSemiClosed :: Handle -> IO Bool
1340 return (not (ho || hc))
1343 hIsReadable :: Handle -> IO Bool
1344 hIsReadable (DuplexHandle _ _ _) = return True
1345 hIsReadable handle =
1346 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1347 case haType handle_ of
1348 ClosedHandle -> ioe_closedHandle
1349 SemiClosedHandle -> ioe_closedHandle
1350 htype -> return (isReadableHandleType htype)
1352 hIsWritable :: Handle -> IO Bool
1353 hIsWritable (DuplexHandle _ _ _) = return True
1354 hIsWritable handle =
1355 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1356 case haType handle_ of
1357 ClosedHandle -> ioe_closedHandle
1358 SemiClosedHandle -> ioe_closedHandle
1359 htype -> return (isWritableHandleType htype)
1361 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1364 hGetBuffering :: Handle -> IO BufferMode
1365 hGetBuffering handle =
1366 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1367 case haType handle_ of
1368 ClosedHandle -> ioe_closedHandle
1370 -- We're being non-standard here, and allow the buffering
1371 -- of a semi-closed handle to be queried. -- sof 6/98
1372 return (haBufferMode handle_) -- could be stricter..
1374 hIsSeekable :: Handle -> IO Bool
1375 hIsSeekable handle =
1376 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1377 case haType handle_ of
1378 ClosedHandle -> ioe_closedHandle
1379 SemiClosedHandle -> ioe_closedHandle
1380 AppendHandle -> return False
1381 _ -> do t <- fdType (haFD handle_)
1382 return (t == RegularFile
1384 || tEXT_MODE_SEEK_ALLOWED))
1386 -- -----------------------------------------------------------------------------
1387 -- Changing echo status (Non-standard GHC extensions)
1389 -- | Set the echoing status of a handle connected to a terminal.
1391 hSetEcho :: Handle -> Bool -> IO ()
1392 hSetEcho handle on = do
1393 isT <- hIsTerminalDevice handle
1397 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1398 case haType handle_ of
1399 ClosedHandle -> ioe_closedHandle
1400 _ -> setEcho (haFD handle_) on
1402 -- | Get the echoing status of a handle connected to a terminal.
1404 hGetEcho :: Handle -> IO Bool
1405 hGetEcho handle = do
1406 isT <- hIsTerminalDevice handle
1410 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1411 case haType handle_ of
1412 ClosedHandle -> ioe_closedHandle
1413 _ -> getEcho (haFD handle_)
1415 -- | Is the handle connected to a terminal?
1417 hIsTerminalDevice :: Handle -> IO Bool
1418 hIsTerminalDevice handle = do
1419 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1420 case haType handle_ of
1421 ClosedHandle -> ioe_closedHandle
1422 _ -> fdIsTTY (haFD handle_)
1424 -- -----------------------------------------------------------------------------
1427 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1428 -- (See also 'openBinaryFile'.)
1430 hSetBinaryMode :: Handle -> Bool -> IO ()
1431 hSetBinaryMode handle bin =
1432 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1433 do throwErrnoIfMinus1_ "hSetBinaryMode"
1434 (setmode (fromIntegral (haFD handle_)) bin)
1435 return handle_{haIsBin=bin}
1437 foreign import ccall unsafe "__hscore_setmode"
1438 setmode :: CInt -> Bool -> IO CInt
1440 -- -----------------------------------------------------------------------------
1441 -- Duplicating a Handle
1443 -- |Returns a duplicate of the original handle, with its own buffer
1444 -- and file pointer. The original handle's buffer is flushed, including
1445 -- discarding any input data, before the handle is duplicated.
1447 hDuplicate :: Handle -> IO Handle
1448 hDuplicate h@(FileHandle path m) = do
1449 new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1450 new_m <- newMVar new_h_
1451 return (FileHandle path new_m)
1452 hDuplicate h@(DuplexHandle path r w) = do
1453 new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1454 new_w <- newMVar new_w_
1455 new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1456 new_r <- newMVar new_r_
1457 return (DuplexHandle path new_r new_w)
1459 dupHandle_ other_side h_ = do
1460 -- flush the buffer first, so we don't have to copy its contents
1462 new_fd <- c_dup (fromIntegral (haFD h_))
1463 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1464 ioref <- newIORef buffer
1465 ioref_buffers <- newIORef BufferListNil
1467 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1469 haBuffers = ioref_buffers,
1470 haOtherSide = other_side }
1471 return (h_, new_handle_)
1473 -- -----------------------------------------------------------------------------
1474 -- Replacing a Handle
1477 Makes the second handle a duplicate of the first handle. The second
1478 handle will be closed first, if it is not already.
1480 This can be used to retarget the standard Handles, for example:
1482 > do h <- openFile "mystdout" WriteMode
1483 > hDuplicateTo h stdout
1486 hDuplicateTo :: Handle -> Handle -> IO ()
1487 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
1488 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1489 _ <- hClose_help h2_
1490 withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1491 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
1492 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1493 _ <- hClose_help w2_
1494 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1495 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1496 _ <- hClose_help r2_
1497 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1499 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1500 "handles are incompatible" Nothing)
1502 -- ---------------------------------------------------------------------------
1505 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1506 -- than the (pure) instance of 'Show' for 'Handle'.
1508 hShow :: Handle -> IO String
1509 hShow h@(FileHandle path _) = showHandle' path False h
1510 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1512 showHandle' filepath is_duplex h =
1513 withHandle_ "showHandle" h $ \hdl_ ->
1515 showType | is_duplex = showString "duplex (read-write)"
1516 | otherwise = shows (haType hdl_)
1520 showHdl (haType hdl_)
1521 (showString "loc=" . showString filepath . showChar ',' .
1522 showString "type=" . showType . showChar ',' .
1523 showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1524 showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1528 showHdl :: HandleType -> ShowS -> ShowS
1531 ClosedHandle -> shows ht . showString "}"
1534 showBufMode :: Buffer -> BufferMode -> ShowS
1535 showBufMode buf bmo =
1537 NoBuffering -> showString "none"
1538 LineBuffering -> showString "line"
1539 BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1540 BlockBuffering Nothing -> showString "block " . showParen True (shows def)
1545 -- ---------------------------------------------------------------------------
1549 puts :: String -> IO ()
1550 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1554 -- -----------------------------------------------------------------------------
1557 throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
1558 throwErrnoIfMinus1RetryOnBlock loc f on_block =
1561 if (res :: CInt) == -1
1565 then throwErrnoIfMinus1RetryOnBlock loc f on_block
1566 else if err == eWOULDBLOCK || err == eAGAIN
1571 -- -----------------------------------------------------------------------------
1572 -- wrappers to platform-specific constants:
1574 foreign import ccall unsafe "__hscore_supportsTextMode"
1575 tEXT_MODE_SEEK_ALLOWED :: Bool
1577 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1578 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1579 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1580 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt