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, fillReadBuffer,
26 readRawBuffer, readRawBufferPtr,
27 writeRawBuffer, writeRawBufferPtr,
30 {- ought to be unnecessary, but just in case.. -}
31 write_off, write_rawBuffer,
32 read_off, read_rawBuffer,
34 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
36 stdin, stdout, stderr,
37 IOMode(..), IOModeEx(..), openFile, openFileEx, openFd, fdToHandle,
38 hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
39 hFlush, hDuplicate, hDuplicateTo,
43 HandlePosn(..), hGetPosn, hSetPosn,
44 SeekMode(..), hSeek, hTell,
46 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
47 hSetEcho, hGetEcho, hIsTerminalDevice,
62 import System.IO.Error
69 import GHC.Read ( Read )
74 import GHC.Num ( Integer(..), Num(..) )
76 import GHC.Real ( toInteger )
80 -- -----------------------------------------------------------------------------
83 -- hWaitForInput blocks (should use a timeout)
85 -- unbuffered hGetLine is a bit dodgy
87 -- hSetBuffering: can't change buffering on a stream,
88 -- when the read buffer is non-empty? (no way to flush the buffer)
90 -- ---------------------------------------------------------------------------
91 -- Are files opened by default in text or binary mode, if the user doesn't
94 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
96 -- ---------------------------------------------------------------------------
97 -- Creating a new handle
99 newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
100 newFileHandle finalizer hc = do
102 addMVarFinalizer m (finalizer m)
103 return (FileHandle m)
105 -- ---------------------------------------------------------------------------
106 -- Working with Handles
109 In the concurrent world, handles are locked during use. This is done
110 by wrapping an MVar around the handle which acts as a mutex over
111 operations on the handle.
113 To avoid races, we use the following bracketing operations. The idea
114 is to obtain the lock, do some operation and replace the lock again,
115 whether the operation succeeded or failed. We also want to handle the
116 case where the thread receives an exception while processing the IO
117 operation: in these cases we also want to relinquish the lock.
119 There are three versions of @withHandle@: corresponding to the three
120 possible combinations of:
122 - the operation may side-effect the handle
123 - the operation may return a result
125 If the operation generates an error or an exception is raised, the
126 original handle is always replaced [ this is the case at the moment,
127 but we might want to revisit this in the future --SDM ].
130 {-# INLINE withHandle #-}
131 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
132 withHandle fun h@(FileHandle m) act = withHandle' fun h m act
133 withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
135 withHandle' :: String -> Handle -> MVar Handle__
136 -> (Handle__ -> IO (Handle__,a)) -> IO a
137 withHandle' fun h m act =
140 checkBufferInvariants h_
141 (h',v) <- catchException (act h_)
142 (\ err -> putMVar m h_ >>
144 IOException ex -> ioError (augmentIOError ex fun h h_)
146 checkBufferInvariants h'
150 {-# INLINE withHandle_ #-}
151 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
152 withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
153 withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
155 withHandle_' fun h m act =
158 checkBufferInvariants h_
159 v <- catchException (act h_)
160 (\ err -> putMVar m h_ >>
162 IOException ex -> ioError (augmentIOError ex fun h h_)
164 checkBufferInvariants h_
168 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
169 withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
170 withAllHandles__ fun h@(DuplexHandle r w) act = do
171 withHandle__' fun h r act
172 withHandle__' fun h w act
174 withHandle__' fun h m act =
177 checkBufferInvariants h_
178 h' <- catchException (act h_)
179 (\ err -> putMVar m h_ >>
181 IOException ex -> ioError (augmentIOError ex fun h h_)
183 checkBufferInvariants h'
187 augmentIOError (IOError _ iot _ str fp) fun h h_
188 = IOError (Just h) iot fun str filepath
189 where filepath | Just _ <- fp = fp
190 | otherwise = Just (haFilePath h_)
192 -- ---------------------------------------------------------------------------
193 -- Wrapper for write operations.
195 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
196 wantWritableHandle fun h@(FileHandle m) act
197 = wantWritableHandle' fun h m act
198 wantWritableHandle fun h@(DuplexHandle _ m) act
199 = wantWritableHandle' fun h m act
200 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
203 :: String -> Handle -> MVar Handle__
204 -> (Handle__ -> IO a) -> IO a
205 wantWritableHandle' fun h m act
206 = withHandle_' fun h m (checkWritableHandle act)
208 checkWritableHandle act handle_
209 = case haType handle_ of
210 ClosedHandle -> ioe_closedHandle
211 SemiClosedHandle -> ioe_closedHandle
212 ReadHandle -> ioe_notWritable
213 ReadWriteHandle -> do
214 let ref = haBuffer handle_
217 if not (bufferIsWritable buf)
218 then do b <- flushReadBuffer (haFD handle_) buf
219 return b{ bufState=WriteBuffer }
221 writeIORef ref new_buf
223 _other -> act handle_
225 -- ---------------------------------------------------------------------------
226 -- Wrapper for read operations.
228 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
229 wantReadableHandle fun h@(FileHandle m) act
230 = wantReadableHandle' fun h m act
231 wantReadableHandle fun h@(DuplexHandle m _) act
232 = wantReadableHandle' fun h m act
233 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
236 :: String -> Handle -> MVar Handle__
237 -> (Handle__ -> IO a) -> IO a
238 wantReadableHandle' fun h m act
239 = withHandle_' fun h m (checkReadableHandle act)
241 checkReadableHandle act handle_ =
242 case haType handle_ of
243 ClosedHandle -> ioe_closedHandle
244 SemiClosedHandle -> ioe_closedHandle
245 AppendHandle -> ioe_notReadable
246 WriteHandle -> ioe_notReadable
247 ReadWriteHandle -> do
248 let ref = haBuffer handle_
250 when (bufferIsWritable buf) $ do
251 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
252 writeIORef ref new_buf{ bufState=ReadBuffer }
254 _other -> act handle_
256 -- ---------------------------------------------------------------------------
257 -- Wrapper for seek operations.
259 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
260 wantSeekableHandle fun h@(DuplexHandle _ _) _act =
261 ioException (IOError (Just h) IllegalOperation fun
262 "handle is not seekable" Nothing)
263 wantSeekableHandle fun h@(FileHandle m) act =
264 withHandle_' fun h m (checkSeekableHandle act)
266 checkSeekableHandle act handle_ =
267 case haType handle_ of
268 ClosedHandle -> ioe_closedHandle
269 SemiClosedHandle -> ioe_closedHandle
270 AppendHandle -> ioe_notSeekable
271 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
272 | otherwise -> ioe_notSeekable_notBin
274 -- -----------------------------------------------------------------------------
277 ioe_closedHandle, ioe_EOF,
278 ioe_notReadable, ioe_notWritable,
279 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
281 ioe_closedHandle = ioException
282 (IOError Nothing IllegalOperation ""
283 "handle is closed" Nothing)
284 ioe_EOF = ioException
285 (IOError Nothing EOF "" "" Nothing)
286 ioe_notReadable = ioException
287 (IOError Nothing IllegalOperation ""
288 "handle is not open for reading" Nothing)
289 ioe_notWritable = ioException
290 (IOError Nothing IllegalOperation ""
291 "handle is not open for writing" Nothing)
292 ioe_notSeekable = ioException
293 (IOError Nothing IllegalOperation ""
294 "handle is not seekable" Nothing)
295 ioe_notSeekable_notBin = ioException
296 (IOError Nothing IllegalOperation ""
297 "seek operations on text-mode handles are not allowed on this platform"
300 ioe_bufsiz :: Int -> IO a
301 ioe_bufsiz n = ioException
302 (IOError Nothing InvalidArgument "hSetBuffering"
303 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
304 -- 9 => should be parens'ified.
306 -- -----------------------------------------------------------------------------
309 -- For a duplex handle, we arrange that the read side points to the write side
310 -- (and hence keeps it alive if the read side is alive). This is done by
311 -- having the haOtherSide field of the read side point to the read side.
312 -- The finalizer is then placed on the write side, and the handle only gets
313 -- finalized once, when both sides are no longer required.
315 stdHandleFinalizer :: MVar Handle__ -> IO ()
316 stdHandleFinalizer m = do
318 flushWriteBufferOnly h_
320 handleFinalizer :: MVar Handle__ -> IO ()
321 handleFinalizer m = do
326 -- ---------------------------------------------------------------------------
327 -- Grimy buffer operations
330 checkBufferInvariants h_ = do
331 let ref = haBuffer h_
332 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
337 && ( r /= w || (r == 0 && w == 0) )
338 && ( state /= WriteBuffer || r == 0 )
339 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
341 then error "buffer invariant violation"
344 checkBufferInvariants h_ = return ()
347 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
348 newEmptyBuffer b state size
349 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
351 allocateBuffer :: Int -> BufferState -> IO Buffer
352 allocateBuffer sz@(I# size) state = IO $ \s ->
353 #ifdef mingw32_TARGET_OS
354 -- To implement asynchronous I/O under Win32, we have to pass
355 -- buffer references to external threads that handles the
356 -- filling/emptying of their contents. Hence, the buffer cannot
357 -- be moved around by the GC.
358 case newPinnedByteArray# size s of { (# s, b #) ->
360 case newByteArray# size s of { (# s, b #) ->
362 (# s, newEmptyBuffer b state sz #) }
364 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
365 writeCharIntoBuffer slab (I# off) (C# c)
366 = IO $ \s -> case writeCharArray# slab off c s of
367 s -> (# s, I# (off +# 1#) #)
369 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
370 readCharFromBuffer slab (I# off)
371 = IO $ \s -> case readCharArray# slab off s of
372 (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
374 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
375 getBuffer fd state = do
376 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
377 ioref <- newIORef buffer
381 | is_tty = LineBuffering
382 | otherwise = BlockBuffering Nothing
384 return (ioref, buffer_mode)
386 mkUnBuffer :: IO (IORef Buffer)
388 buffer <- allocateBuffer 1 ReadBuffer
391 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
392 flushWriteBufferOnly :: Handle__ -> IO ()
393 flushWriteBufferOnly h_ = do
397 new_buf <- if bufferIsWritable buf
398 then flushWriteBuffer fd (haIsStream h_) buf
400 writeIORef ref new_buf
402 -- flushBuffer syncs the file with the buffer, including moving the
403 -- file pointer backwards in the case of a read buffer.
404 flushBuffer :: Handle__ -> IO ()
406 let ref = haBuffer h_
411 ReadBuffer -> flushReadBuffer (haFD h_) buf
412 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
414 writeIORef ref flushed_buf
416 -- When flushing a read buffer, we seek backwards by the number of
417 -- characters in the buffer. The file descriptor must therefore be
418 -- seekable: attempting to flush the read buffer on an unseekable
419 -- handle is not allowed.
421 flushReadBuffer :: FD -> Buffer -> IO Buffer
422 flushReadBuffer fd buf
423 | bufferEmpty buf = return buf
425 let off = negate (bufWPtr buf - bufRPtr buf)
427 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
429 throwErrnoIfMinus1Retry "flushReadBuffer"
430 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
431 return buf{ bufWPtr=0, bufRPtr=0 }
433 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
434 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
437 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
440 then return (buf{ bufRPtr=0, bufWPtr=0 })
442 res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
443 (fromIntegral r) (fromIntegral bytes)
444 let res' = fromIntegral res
446 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
447 else return buf{ bufRPtr=0, bufWPtr=0 }
449 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
450 fillReadBuffer fd is_line is_stream
451 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
452 -- buffer better be empty:
453 assert (r == 0 && w == 0) $ do
454 fillReadBufferLoop fd is_line is_stream buf b w size
456 -- For a line buffer, we just get the first chunk of data to arrive,
457 -- and don't wait for the whole buffer to be full (but we *do* wait
458 -- until some data arrives). This isn't really line buffering, but it
459 -- appears to be what GHC has done for a long time, and I suspect it
460 -- is more useful than line buffering in most cases.
462 fillReadBufferLoop fd is_line is_stream buf b w size = do
464 if bytes == 0 -- buffer full?
465 then return buf{ bufRPtr=0, bufWPtr=w }
468 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
470 res <- readRawBuffer "fillReadBuffer" fd is_stream b
471 (fromIntegral w) (fromIntegral bytes)
472 let res' = fromIntegral res
474 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
479 else return buf{ bufRPtr=0, bufWPtr=w }
480 else if res' < bytes && not is_line
481 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
482 else return buf{ bufRPtr=0, bufWPtr=w+res' }
485 -- Low level routines for reading/writing to (raw)buffers:
487 #ifndef mingw32_TARGET_OS
488 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
489 readRawBuffer loc fd is_stream buf off len =
490 throwErrnoIfMinus1RetryMayBlock loc
491 (read_rawBuffer fd is_stream buf off len)
494 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
495 readRawBufferPtr loc fd is_stream buf off len =
496 throwErrnoIfMinus1RetryMayBlock loc
497 (read_off fd is_stream buf off len)
500 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
501 writeRawBuffer loc fd is_stream buf off len =
502 throwErrnoIfMinus1RetryMayBlock loc
503 (write_rawBuffer (fromIntegral fd) is_stream buf off len)
506 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
507 writeRawBufferPtr loc fd is_stream buf off len =
508 throwErrnoIfMinus1RetryMayBlock loc
509 (write_off (fromIntegral fd) is_stream buf off len)
512 foreign import ccall unsafe "__hscore_PrelHandle_read"
513 read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
515 foreign import ccall unsafe "__hscore_PrelHandle_read"
516 read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
518 foreign import ccall unsafe "__hscore_PrelHandle_write"
519 write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
521 foreign import ccall unsafe "__hscore_PrelHandle_write"
522 write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
525 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
526 readRawBuffer loc fd is_stream buf off len = do
527 (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
530 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
531 else return (fromIntegral l)
533 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
534 readRawBufferPtr loc fd is_stream buf off len = do
535 (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
538 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
539 else return (fromIntegral l)
541 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
542 writeRawBuffer loc fd is_stream buf off len = do
543 (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
546 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
547 else return (fromIntegral l)
549 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
550 writeRawBufferPtr loc fd is_stream buf off len = do
551 (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
554 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
555 else return (fromIntegral l)
557 foreign import ccall unsafe "__hscore_PrelHandle_read"
558 read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
560 foreign import ccall unsafe "__hscore_PrelHandle_read"
561 read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
563 foreign import ccall unsafe "__hscore_PrelHandle_write"
564 write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
566 foreign import ccall unsafe "__hscore_PrelHandle_write"
567 write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
571 -- ---------------------------------------------------------------------------
574 -- Three handles are allocated during program initialisation. The first
575 -- two manage input or output from the Haskell program's standard input
576 -- or output channel respectively. The third manages output to the
577 -- standard error channel. These handles are initially open.
584 stdin = unsafePerformIO $ do
585 -- ToDo: acquire lock
586 setNonBlockingFD fd_stdin
587 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
588 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
591 stdout = unsafePerformIO $ do
592 -- ToDo: acquire lock
593 -- We don't set non-blocking mode on stdout or sterr, because
594 -- some shells don't recover properly.
595 -- setNonBlockingFD fd_stdout
596 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
597 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
600 stderr = unsafePerformIO $ do
601 -- ToDo: acquire lock
602 -- We don't set non-blocking mode on stdout or sterr, because
603 -- some shells don't recover properly.
604 -- setNonBlockingFD fd_stderr
606 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
608 -- ---------------------------------------------------------------------------
609 -- Opening and Closing Files
612 Computation `openFile file mode' allocates and returns a new, open
613 handle to manage the file `file'. It manages input if `mode'
614 is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
615 and both input and output if mode is `ReadWriteMode'.
617 If the file does not exist and it is opened for output, it should be
618 created as a new file. If `mode' is `WriteMode' and the file
619 already exists, then it should be truncated to zero length. The
620 handle is positioned at the end of the file if `mode' is
621 `AppendMode', and otherwise at the beginning (in which case its
622 internal position is 0).
624 Implementations should enforce, locally to the Haskell process,
625 multiple-reader single-writer locking on files, which is to say that
626 there may either be many handles on the same file which manage input,
627 or just one handle on the file which manages output. If any open or
628 semi-closed handle is managing a file for output, no new handle can be
629 allocated for that file. If any open or semi-closed handle is
630 managing a file for input, new handles can only be allocated if they
631 do not manage output.
633 Two files are the same if they have the same absolute name. An
634 implementation is free to impose stricter conditions.
640 deriving (Eq, Read, Show)
642 addFilePathToIOError fun fp (IOError h iot _ str _)
643 = IOError h iot fun str (Just fp)
645 openFile :: FilePath -> IOMode -> IO Handle
648 (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
651 (\e -> ioError (addFilePathToIOError "openFile" fp e))
653 openFileEx :: FilePath -> IOModeEx -> IO Handle
657 (\e -> ioError (addFilePathToIOError "openFileEx" fp e))
660 openFile' filepath ex_mode =
661 withCString filepath $ \ f ->
666 BinaryMode bmo -> (bmo, True)
667 TextMode tmo -> (tmo, False)
669 oflags1 = case mode of
670 ReadMode -> read_flags
671 WriteMode -> write_flags
672 ReadWriteMode -> rw_flags
673 AppendMode -> append_flags
675 truncate | WriteMode <- mode = True
682 oflags = oflags1 .|. binary_flags
685 -- the old implementation had a complicated series of three opens,
686 -- which is perhaps because we have to be careful not to open
687 -- directories. However, the man pages I've read say that open()
688 -- always returns EISDIR if the file is a directory and was opened
689 -- for writing, so I think we're ok with a single open() here...
690 fd <- fromIntegral `liftM`
691 throwErrnoIfMinus1Retry "openFile"
692 (c_open f (fromIntegral oflags) 0o666)
694 openFd fd Nothing filepath mode binary truncate
695 -- ASSERT: if we just created the file, then openFd won't fail
696 -- (so we don't need to worry about removing the newly created file
697 -- in the event of an error).
700 std_flags = o_NONBLOCK .|. o_NOCTTY
701 output_flags = std_flags .|. o_CREAT
702 read_flags = std_flags .|. o_RDONLY
703 write_flags = output_flags .|. o_WRONLY
704 rw_flags = output_flags .|. o_RDWR
705 append_flags = write_flags .|. o_APPEND
707 -- ---------------------------------------------------------------------------
710 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
711 openFd fd mb_fd_type filepath mode binary truncate = do
712 -- turn on non-blocking mode
715 let (ha_type, write) =
717 ReadMode -> ( ReadHandle, False )
718 WriteMode -> ( WriteHandle, True )
719 ReadWriteMode -> ( ReadWriteHandle, True )
720 AppendMode -> ( AppendHandle, True )
722 -- open() won't tell us if it was a directory if we only opened for
723 -- reading, so check again.
728 let is_stream = fd_type == Stream
731 ioException (IOError Nothing InappropriateType "openFile"
732 "is a directory" Nothing)
735 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
736 | otherwise -> mkFileHandle fd is_stream filepath ha_type binary
738 -- regular files need to be locked
740 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
742 ioException (IOError Nothing ResourceBusy "openFile"
743 "file is locked" Nothing)
745 -- truncate the file if necessary
746 when truncate (fileTruncate filepath)
748 mkFileHandle fd is_stream filepath ha_type binary
751 fdToHandle :: FD -> IO Handle
754 let fd_str = "<file descriptor: " ++ show fd ++ ">"
755 openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
757 foreign import ccall unsafe "lockFile"
758 lockFile :: CInt -> CInt -> CInt -> IO CInt
760 foreign import ccall unsafe "unlockFile"
761 unlockFile :: CInt -> IO CInt
763 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
765 mkStdHandle fd filepath ha_type buf bmode = do
766 spares <- newIORef BufferListNil
767 newFileHandle stdHandleFinalizer
768 (Handle__ { haFD = fd,
770 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
772 haBufferMode = bmode,
773 haFilePath = filepath,
776 haOtherSide = Nothing
779 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
780 mkFileHandle fd is_stream filepath ha_type binary = do
781 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
782 spares <- newIORef BufferListNil
783 newFileHandle handleFinalizer
784 (Handle__ { haFD = fd,
787 haIsStream = is_stream,
788 haBufferMode = bmode,
789 haFilePath = filepath,
792 haOtherSide = Nothing
795 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
796 mkDuplexHandle fd is_stream filepath binary = do
797 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
798 w_spares <- newIORef BufferListNil
800 Handle__ { haFD = fd,
801 haType = WriteHandle,
803 haIsStream = is_stream,
804 haBufferMode = w_bmode,
805 haFilePath = filepath,
807 haBuffers = w_spares,
808 haOtherSide = Nothing
810 write_side <- newMVar w_handle_
812 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
813 r_spares <- newIORef BufferListNil
815 Handle__ { haFD = fd,
818 haIsStream = is_stream,
819 haBufferMode = r_bmode,
820 haFilePath = filepath,
822 haBuffers = r_spares,
823 haOtherSide = Just write_side
825 read_side <- newMVar r_handle_
827 addMVarFinalizer write_side (handleFinalizer write_side)
828 return (DuplexHandle read_side write_side)
831 initBufferState ReadHandle = ReadBuffer
832 initBufferState _ = WriteBuffer
834 -- ---------------------------------------------------------------------------
837 -- Computation `hClose hdl' makes handle `hdl' closed. Before the
838 -- computation finishes, any items buffered for output and not already
839 -- sent to the operating system are flushed as for `hFlush'.
841 -- For a duplex handle, we close&flush the write side, and just close
844 hClose :: Handle -> IO ()
845 hClose h@(FileHandle m) = hClose' h m
846 hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
848 hClose' h m = withHandle__' "hClose" h m $ hClose_help
850 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
851 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
852 -- then closed immediately. We have to be careful with DuplexHandles
853 -- though: we have to leave the closing to the finalizer in that case,
854 -- because the write side may still be in use.
855 hClose_help :: Handle__ -> IO Handle__
856 hClose_help handle_ =
857 case haType handle_ of
858 ClosedHandle -> return handle_
860 let fd = haFD handle_
861 c_fd = fromIntegral fd
863 flushWriteBufferOnly handle_
865 -- close the file descriptor, but not when this is the read
866 -- side of a duplex handle, and not when this is one of the
868 case haOtherSide handle_ of
870 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
871 throwErrnoIfMinus1Retry_ "hClose"
872 #ifdef mingw32_TARGET_OS
873 (closeFd (haIsStream handle_) c_fd)
879 -- free the spare buffers
880 writeIORef (haBuffers handle_) BufferListNil
885 -- we must set the fd to -1, because the finalizer is going
886 -- to run eventually and try to close/unlock it.
887 return (handle_{ haFD = -1,
888 haType = ClosedHandle
891 -----------------------------------------------------------------------------
892 -- Detecting the size of a file
894 -- For a handle `hdl' which attached to a physical file, `hFileSize
895 -- hdl' returns the size of `hdl' in terms of the number of items
896 -- which can be read from `hdl'.
898 hFileSize :: Handle -> IO Integer
900 withHandle_ "hFileSize" handle $ \ handle_ -> do
901 case haType handle_ of
902 ClosedHandle -> ioe_closedHandle
903 SemiClosedHandle -> ioe_closedHandle
904 _ -> do flushWriteBufferOnly handle_
905 r <- fdFileSize (haFD handle_)
908 else ioException (IOError Nothing InappropriateType "hFileSize"
909 "not a regular file" Nothing)
911 -- ---------------------------------------------------------------------------
912 -- Detecting the End of Input
914 -- For a readable handle `hdl', `hIsEOF hdl' returns
915 -- `True' if no further input can be taken from `hdl' or for a
916 -- physical file, if the current I/O position is equal to the length of
917 -- the file. Otherwise, it returns `False'.
919 hIsEOF :: Handle -> IO Bool
922 (do hLookAhead handle; return False)
923 (\e -> if isEOFError e then return True else ioError e)
928 -- ---------------------------------------------------------------------------
931 -- hLookahead returns the next character from the handle without
932 -- removing it from the input buffer, blocking until a character is
935 hLookAhead :: Handle -> IO Char
936 hLookAhead handle = do
937 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
938 let ref = haBuffer handle_
940 is_line = haBufferMode handle_ == LineBuffering
943 -- fill up the read buffer if necessary
944 new_buf <- if bufferEmpty buf
945 then fillReadBuffer fd is_line (haIsStream handle_) buf
948 writeIORef ref new_buf
950 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
953 -- ---------------------------------------------------------------------------
954 -- Buffering Operations
956 -- Three kinds of buffering are supported: line-buffering,
957 -- block-buffering or no-buffering. See GHC.IOBase for definition and
958 -- further explanation of what the type represent.
960 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
961 -- handle hdl on subsequent reads and writes.
963 -- * If mode is LineBuffering, line-buffering should be enabled if possible.
965 -- * If mode is `BlockBuffering size', then block-buffering
966 -- should be enabled if possible. The size of the buffer is n items
967 -- if size is `Just n' and is otherwise implementation-dependent.
969 -- * If mode is NoBuffering, then buffering is disabled if possible.
971 -- If the buffer mode is changed from BlockBuffering or
972 -- LineBuffering to NoBuffering, then any items in the output
973 -- buffer are written to the device, and any items in the input buffer
974 -- are discarded. The default buffering mode when a handle is opened
975 -- is implementation-dependent and may depend on the object which is
976 -- attached to that handle.
978 hSetBuffering :: Handle -> BufferMode -> IO ()
979 hSetBuffering handle mode =
980 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
981 case haType handle_ of
982 ClosedHandle -> ioe_closedHandle
985 - we flush the old buffer regardless of whether
986 the new buffer could fit the contents of the old buffer
988 - allow a handle's buffering to change even if IO has
989 occurred (ANSI C spec. does not allow this, nor did
990 the previous implementation of IO.hSetBuffering).
991 - a non-standard extension is to allow the buffering
992 of semi-closed handles to change [sof 6/98]
996 let state = initBufferState (haType handle_)
999 -- we always have a 1-character read buffer for
1000 -- unbuffered handles: it's needed to
1001 -- support hLookAhead.
1002 NoBuffering -> allocateBuffer 1 ReadBuffer
1003 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
1004 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1005 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
1006 | otherwise -> allocateBuffer n state
1007 writeIORef (haBuffer handle_) new_buf
1009 -- for input terminals we need to put the terminal into
1010 -- cooked or raw mode depending on the type of buffering.
1011 is_tty <- fdIsTTY (haFD handle_)
1012 when (is_tty && isReadableHandleType (haType handle_)) $
1014 #ifndef mingw32_TARGET_OS
1015 -- 'raw' mode under win32 is a bit too specialised (and troublesome
1016 -- for most common uses), so simply disable its use here.
1017 NoBuffering -> setCooked (haFD handle_) False
1019 _ -> setCooked (haFD handle_) True
1021 -- throw away spare buffers, they might be the wrong size
1022 writeIORef (haBuffers handle_) BufferListNil
1024 return (handle_{ haBufferMode = mode })
1026 -- -----------------------------------------------------------------------------
1029 -- The action `hFlush hdl' causes any items buffered for output
1030 -- in handle `hdl' to be sent immediately to the operating
1033 hFlush :: Handle -> IO ()
1035 wantWritableHandle "hFlush" handle $ \ handle_ -> do
1036 buf <- readIORef (haBuffer handle_)
1037 if bufferIsWritable buf && not (bufferEmpty buf)
1038 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1039 writeIORef (haBuffer handle_) flushed_buf
1043 -- -----------------------------------------------------------------------------
1044 -- Repositioning Handles
1046 data HandlePosn = HandlePosn Handle HandlePosition
1048 instance Eq HandlePosn where
1049 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1051 instance Show HandlePosn where
1052 showsPrec p (HandlePosn h pos) =
1053 showsPrec p h . showString " at position " . shows pos
1055 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1056 -- We represent it as an Integer on the Haskell side, but
1057 -- cheat slightly in that hGetPosn calls upon a C helper
1058 -- that reports the position back via (merely) an Int.
1059 type HandlePosition = Integer
1061 -- Computation `hGetPosn hdl' returns the current I/O position of
1062 -- `hdl' as an abstract position. Computation `hSetPosn p' sets the
1063 -- position of `hdl' to a previously obtained position `p'.
1065 hGetPosn :: Handle -> IO HandlePosn
1066 hGetPosn handle = do
1067 posn <- hTell handle
1068 return (HandlePosn handle posn)
1070 hSetPosn :: HandlePosn -> IO ()
1071 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1073 -- ---------------------------------------------------------------------------
1077 The action `hSeek hdl mode i' sets the position of handle
1078 `hdl' depending on `mode'. If `mode' is
1080 * AbsoluteSeek - The position of `hdl' is set to `i'.
1081 * RelativeSeek - The position of `hdl' is set to offset `i' from
1082 the current position.
1083 * SeekFromEnd - The position of `hdl' is set to offset `i' from
1084 the end of the file.
1086 Some handles may not be seekable (see `hIsSeekable'), or only
1087 support a subset of the possible positioning operations (e.g. it may
1088 only be possible to seek to the end of a tape, or to a positive
1089 offset from the beginning or current position).
1091 It is not possible to set a negative I/O position, or for a physical
1092 file, an I/O position beyond the current end-of-file.
1095 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1096 seeking at or past EOF.
1098 - we possibly deviate from the report on the issue of seeking within
1099 the buffer and whether to flush it or not. The report isn't exactly
1103 data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
1104 deriving (Eq, Ord, Ix, Enum, Read, Show)
1106 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1107 hSeek handle mode offset =
1108 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1110 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1112 let ref = haBuffer handle_
1113 buf <- readIORef ref
1119 throwErrnoIfMinus1Retry_ "hSeek"
1120 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1123 whence = case mode of
1124 AbsoluteSeek -> sEEK_SET
1125 RelativeSeek -> sEEK_CUR
1126 SeekFromEnd -> sEEK_END
1128 if bufferIsWritable buf
1129 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1130 writeIORef ref new_buf
1134 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1135 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1138 new_buf <- flushReadBuffer (haFD handle_) buf
1139 writeIORef ref new_buf
1143 hTell :: Handle -> IO Integer
1145 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1147 #if defined(mingw32_TARGET_OS)
1148 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1149 -- so we can't easily calculate the file position using the
1150 -- current buffer size. Just flush instead.
1153 let fd = fromIntegral (haFD handle_)
1154 posn <- fromIntegral `liftM`
1155 throwErrnoIfMinus1Retry "hGetPosn"
1156 (c_lseek fd 0 sEEK_CUR)
1158 let ref = haBuffer handle_
1159 buf <- readIORef ref
1162 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1163 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1165 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1166 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1170 -- -----------------------------------------------------------------------------
1171 -- Handle Properties
1173 -- A number of operations return information about the properties of a
1174 -- handle. Each of these operations returns `True' if the handle has
1175 -- the specified property, and `False' otherwise.
1177 hIsOpen :: Handle -> IO Bool
1179 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1180 case haType handle_ of
1181 ClosedHandle -> return False
1182 SemiClosedHandle -> return False
1185 hIsClosed :: Handle -> IO Bool
1187 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1188 case haType handle_ of
1189 ClosedHandle -> return True
1192 {- not defined, nor exported, but mentioned
1193 here for documentation purposes:
1195 hSemiClosed :: Handle -> IO Bool
1199 return (not (ho || hc))
1202 hIsReadable :: Handle -> IO Bool
1203 hIsReadable (DuplexHandle _ _) = return True
1204 hIsReadable handle =
1205 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1206 case haType handle_ of
1207 ClosedHandle -> ioe_closedHandle
1208 SemiClosedHandle -> ioe_closedHandle
1209 htype -> return (isReadableHandleType htype)
1211 hIsWritable :: Handle -> IO Bool
1212 hIsWritable (DuplexHandle _ _) = return False
1213 hIsWritable handle =
1214 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1215 case haType handle_ of
1216 ClosedHandle -> ioe_closedHandle
1217 SemiClosedHandle -> ioe_closedHandle
1218 htype -> return (isWritableHandleType htype)
1220 -- Querying how a handle buffers its data:
1222 hGetBuffering :: Handle -> IO BufferMode
1223 hGetBuffering handle =
1224 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1225 case haType handle_ of
1226 ClosedHandle -> ioe_closedHandle
1228 -- We're being non-standard here, and allow the buffering
1229 -- of a semi-closed handle to be queried. -- sof 6/98
1230 return (haBufferMode handle_) -- could be stricter..
1232 hIsSeekable :: Handle -> IO Bool
1233 hIsSeekable handle =
1234 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1235 case haType handle_ of
1236 ClosedHandle -> ioe_closedHandle
1237 SemiClosedHandle -> ioe_closedHandle
1238 AppendHandle -> return False
1239 _ -> do t <- fdType (haFD handle_)
1240 return (t == RegularFile
1242 || tEXT_MODE_SEEK_ALLOWED))
1244 -- -----------------------------------------------------------------------------
1245 -- Changing echo status
1247 -- Non-standard GHC extension is to allow the echoing status
1248 -- of a handles connected to terminals to be reconfigured:
1250 hSetEcho :: Handle -> Bool -> IO ()
1251 hSetEcho handle on = do
1252 isT <- hIsTerminalDevice handle
1256 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1257 case haType handle_ of
1258 ClosedHandle -> ioe_closedHandle
1259 _ -> setEcho (haFD handle_) on
1261 hGetEcho :: Handle -> IO Bool
1262 hGetEcho handle = do
1263 isT <- hIsTerminalDevice handle
1267 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1268 case haType handle_ of
1269 ClosedHandle -> ioe_closedHandle
1270 _ -> getEcho (haFD handle_)
1272 hIsTerminalDevice :: Handle -> IO Bool
1273 hIsTerminalDevice handle = do
1274 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1275 case haType handle_ of
1276 ClosedHandle -> ioe_closedHandle
1277 _ -> fdIsTTY (haFD handle_)
1279 -- -----------------------------------------------------------------------------
1282 -- | On Windows, reading a file in text mode (which is the default) will
1283 -- translate CRLF to LF, and writing will translate LF to CRLF. This
1284 -- is usually what you want with text files. With binary files this is
1285 -- undesirable; also, as usual under Microsoft operating systems, text
1286 -- mode treats control-Z as EOF. Setting binary mode using
1287 -- 'hSetBinaryMode' turns off all special treatment of end-of-line and
1288 -- end-of-file characters.
1290 hSetBinaryMode :: Handle -> Bool -> IO ()
1291 hSetBinaryMode handle bin =
1292 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1293 do throwErrnoIfMinus1_ "hSetBinaryMode"
1294 (setmode (fromIntegral (haFD handle_)) bin)
1295 return handle_{haIsBin=bin}
1297 foreign import ccall unsafe "__hscore_setmode"
1298 setmode :: CInt -> Bool -> IO CInt
1300 -- -----------------------------------------------------------------------------
1301 -- Duplicating a Handle
1303 -- |Returns a duplicate of the original handle, with its own buffer
1304 -- and file pointer. The original handle's buffer is flushed, including
1305 -- discarding any input data, before the handle is duplicated.
1307 hDuplicate :: Handle -> IO Handle
1308 hDuplicate h@(FileHandle m) = do
1309 new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1310 new_m <- newMVar new_h_
1311 return (FileHandle new_m)
1312 hDuplicate h@(DuplexHandle r w) = do
1313 new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1314 new_w <- newMVar new_w_
1315 new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1316 new_r <- newMVar new_r_
1317 return (DuplexHandle new_r new_w)
1319 dupHandle_ other_side h_ = do
1320 -- flush the buffer first, so we don't have to copy its contents
1322 new_fd <- c_dup (fromIntegral (haFD h_))
1323 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1324 ioref <- newIORef buffer
1325 ioref_buffers <- newIORef BufferListNil
1327 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1329 haBuffers = ioref_buffers,
1330 haOtherSide = other_side }
1331 return (h_, new_handle_)
1333 -- -----------------------------------------------------------------------------
1334 -- Replacing a Handle
1337 Makes the second handle a duplicate of the first handle. The second
1338 handle will be closed first, if it is not already.
1340 This can be used to retarget the standard Handles, for example:
1342 > do h <- openFile "mystdout" WriteMode
1343 > hDuplicateTo h stdout
1346 hDuplicateTo :: Handle -> Handle -> IO ()
1347 hDuplicateTo h1@(FileHandle m1) h2@(FileHandle m2) = do
1348 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1349 _ <- hClose_help h2_
1350 withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1351 hDuplicateTo h1@(DuplexHandle r1 w1) h2@(DuplexHandle r2 w2) = do
1352 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1353 _ <- hClose_help w2_
1354 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1355 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1356 _ <- hClose_help r2_
1357 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1359 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1360 "handles are incompatible" Nothing)
1362 -- ---------------------------------------------------------------------------
1366 puts :: String -> IO ()
1367 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1371 -- -----------------------------------------------------------------------------
1372 -- wrappers to platform-specific constants:
1374 foreign import ccall unsafe "__hscore_supportsTextMode"
1375 tEXT_MODE_SEEK_ALLOWED :: Bool
1377 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1378 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1379 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1380 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt