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 read_off, read_off_ba,
27 write_off, write_off_ba, unlockFile,
29 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
31 stdin, stdout, stderr,
32 IOMode(..), IOModeEx(..), openFile, openFileEx, openFd, fdToHandle,
33 hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
34 hFlush, hDuplicate, hDuplicateTo,
38 HandlePosn(..), hGetPosn, hSetPosn,
39 SeekMode(..), hSeek, hTell,
41 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
42 hSetEcho, hGetEcho, hIsTerminalDevice,
55 import System.IO.Error
62 import GHC.Read ( Read )
67 import GHC.Num ( Integer(..), Num(..) )
69 import GHC.Real ( toInteger )
73 -- -----------------------------------------------------------------------------
76 -- hWaitForInput blocks (should use a timeout)
78 -- unbuffered hGetLine is a bit dodgy
80 -- hSetBuffering: can't change buffering on a stream,
81 -- when the read buffer is non-empty? (no way to flush the buffer)
83 -- ---------------------------------------------------------------------------
84 -- Are files opened by default in text or binary mode, if the user doesn't
87 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
89 -- ---------------------------------------------------------------------------
90 -- Creating a new handle
92 newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
93 newFileHandle finalizer hc = do
95 addMVarFinalizer m (finalizer m)
98 -- ---------------------------------------------------------------------------
99 -- Working with Handles
102 In the concurrent world, handles are locked during use. This is done
103 by wrapping an MVar around the handle which acts as a mutex over
104 operations on the handle.
106 To avoid races, we use the following bracketing operations. The idea
107 is to obtain the lock, do some operation and replace the lock again,
108 whether the operation succeeded or failed. We also want to handle the
109 case where the thread receives an exception while processing the IO
110 operation: in these cases we also want to relinquish the lock.
112 There are three versions of @withHandle@: corresponding to the three
113 possible combinations of:
115 - the operation may side-effect the handle
116 - the operation may return a result
118 If the operation generates an error or an exception is raised, the
119 original handle is always replaced [ this is the case at the moment,
120 but we might want to revisit this in the future --SDM ].
123 {-# INLINE withHandle #-}
124 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
125 withHandle fun h@(FileHandle m) act = withHandle' fun h m act
126 withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
128 withHandle' :: String -> Handle -> MVar Handle__
129 -> (Handle__ -> IO (Handle__,a)) -> IO a
130 withHandle' fun h m act =
133 checkBufferInvariants h_
134 (h',v) <- catchException (act h_)
135 (\ err -> putMVar m h_ >>
137 IOException ex -> ioError (augmentIOError ex fun h h_)
139 checkBufferInvariants h'
143 {-# INLINE withHandle_ #-}
144 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
145 withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
146 withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
148 withHandle_' fun h m act =
151 checkBufferInvariants h_
152 v <- catchException (act h_)
153 (\ err -> putMVar m h_ >>
155 IOException ex -> ioError (augmentIOError ex fun h h_)
157 checkBufferInvariants h_
161 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
162 withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
163 withAllHandles__ fun h@(DuplexHandle r w) act = do
164 withHandle__' fun h r act
165 withHandle__' fun h w act
167 withHandle__' fun h m act =
170 checkBufferInvariants h_
171 h' <- catchException (act h_)
172 (\ err -> putMVar m h_ >>
174 IOException ex -> ioError (augmentIOError ex fun h h_)
176 checkBufferInvariants h'
180 augmentIOError (IOError _ iot _ str fp) fun h h_
181 = IOError (Just h) iot fun str filepath
182 where filepath | Just _ <- fp = fp
183 | otherwise = Just (haFilePath h_)
185 -- ---------------------------------------------------------------------------
186 -- Wrapper for write operations.
188 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
189 wantWritableHandle fun h@(FileHandle m) act
190 = wantWritableHandle' fun h m act
191 wantWritableHandle fun h@(DuplexHandle _ m) act
192 = wantWritableHandle' fun h m act
193 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
196 :: String -> Handle -> MVar Handle__
197 -> (Handle__ -> IO a) -> IO a
198 wantWritableHandle' fun h m act
199 = withHandle_' fun h m (checkWritableHandle act)
201 checkWritableHandle act handle_
202 = case haType handle_ of
203 ClosedHandle -> ioe_closedHandle
204 SemiClosedHandle -> ioe_closedHandle
205 ReadHandle -> ioe_notWritable
206 ReadWriteHandle -> do
207 let ref = haBuffer handle_
210 if not (bufferIsWritable buf)
211 then do b <- flushReadBuffer (haFD handle_) buf
212 return b{ bufState=WriteBuffer }
214 writeIORef ref new_buf
216 _other -> act handle_
218 -- ---------------------------------------------------------------------------
219 -- Wrapper for read operations.
221 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
222 wantReadableHandle fun h@(FileHandle m) act
223 = wantReadableHandle' fun h m act
224 wantReadableHandle fun h@(DuplexHandle m _) act
225 = wantReadableHandle' fun h m act
226 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
229 :: String -> Handle -> MVar Handle__
230 -> (Handle__ -> IO a) -> IO a
231 wantReadableHandle' fun h m act
232 = withHandle_' fun h m (checkReadableHandle act)
234 checkReadableHandle act handle_ =
235 case haType handle_ of
236 ClosedHandle -> ioe_closedHandle
237 SemiClosedHandle -> ioe_closedHandle
238 AppendHandle -> ioe_notReadable
239 WriteHandle -> ioe_notReadable
240 ReadWriteHandle -> do
241 let ref = haBuffer handle_
243 when (bufferIsWritable buf) $ do
244 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
245 writeIORef ref new_buf{ bufState=ReadBuffer }
247 _other -> act handle_
249 -- ---------------------------------------------------------------------------
250 -- Wrapper for seek operations.
252 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
253 wantSeekableHandle fun h@(DuplexHandle _ _) _act =
254 ioException (IOError (Just h) IllegalOperation fun
255 "handle is not seekable" Nothing)
256 wantSeekableHandle fun h@(FileHandle m) act =
257 withHandle_' fun h m (checkSeekableHandle act)
259 checkSeekableHandle act handle_ =
260 case haType handle_ of
261 ClosedHandle -> ioe_closedHandle
262 SemiClosedHandle -> ioe_closedHandle
263 AppendHandle -> ioe_notSeekable
264 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
265 | otherwise -> ioe_notSeekable_notBin
267 -- -----------------------------------------------------------------------------
270 ioe_closedHandle, ioe_EOF,
271 ioe_notReadable, ioe_notWritable,
272 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
274 ioe_closedHandle = ioException
275 (IOError Nothing IllegalOperation ""
276 "handle is closed" Nothing)
277 ioe_EOF = ioException
278 (IOError Nothing EOF "" "" Nothing)
279 ioe_notReadable = ioException
280 (IOError Nothing IllegalOperation ""
281 "handle is not open for reading" Nothing)
282 ioe_notWritable = ioException
283 (IOError Nothing IllegalOperation ""
284 "handle is not open for writing" Nothing)
285 ioe_notSeekable = ioException
286 (IOError Nothing IllegalOperation ""
287 "handle is not seekable" Nothing)
288 ioe_notSeekable_notBin = ioException
289 (IOError Nothing IllegalOperation ""
290 "seek operations on text-mode handles are not allowed on this platform"
293 ioe_bufsiz :: Int -> IO a
294 ioe_bufsiz n = ioException
295 (IOError Nothing InvalidArgument "hSetBuffering"
296 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
297 -- 9 => should be parens'ified.
299 -- -----------------------------------------------------------------------------
302 -- For a duplex handle, we arrange that the read side points to the write side
303 -- (and hence keeps it alive if the read side is alive). This is done by
304 -- having the haOtherSide field of the read side point to the read side.
305 -- The finalizer is then placed on the write side, and the handle only gets
306 -- finalized once, when both sides are no longer required.
308 stdHandleFinalizer :: MVar Handle__ -> IO ()
309 stdHandleFinalizer m = do
311 flushWriteBufferOnly h_
313 handleFinalizer :: MVar Handle__ -> IO ()
314 handleFinalizer m = do
317 -- hClose puts both the fd and the handle's type
318 -- into a closed state, so it's a bit excessive
319 -- to test for both here, but caution sometimes
322 case haType h_ of { ClosedHandle{} -> True; _ -> False }
323 fd = fromIntegral (haFD h_)
325 when (not alreadyClosed && fd /= -1) $ do
326 flushWriteBufferOnly h_
328 #ifdef mingw32_TARGET_OS
329 (closeFd (haIsStream h_) fd >> return ())
331 (c_close fd >> return ())
334 -- ---------------------------------------------------------------------------
335 -- Grimy buffer operations
338 checkBufferInvariants h_ = do
339 let ref = haBuffer h_
340 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
345 && ( r /= w || (r == 0 && w == 0) )
346 && ( state /= WriteBuffer || r == 0 )
347 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
349 then error "buffer invariant violation"
352 checkBufferInvariants h_ = return ()
355 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
356 newEmptyBuffer b state size
357 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
359 allocateBuffer :: Int -> BufferState -> IO Buffer
360 allocateBuffer sz@(I# size) state = IO $ \s ->
361 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 <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
443 (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
444 (fromIntegral bytes))
446 let res' = fromIntegral res
448 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
449 else return buf{ bufRPtr=0, bufWPtr=0 }
451 foreign import ccall unsafe "__hscore_PrelHandle_write"
452 write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
454 foreign import ccall unsafe "__hscore_PrelHandle_write"
455 write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
457 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
458 fillReadBuffer fd is_line is_stream
459 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
460 -- buffer better be empty:
461 assert (r == 0 && w == 0) $ do
462 fillReadBufferLoop fd is_line is_stream buf b w size
464 -- For a line buffer, we just get the first chunk of data to arrive,
465 -- and don't wait for the whole buffer to be full (but we *do* wait
466 -- until some data arrives). This isn't really line buffering, but it
467 -- appears to be what GHC has done for a long time, and I suspect it
468 -- is more useful than line buffering in most cases.
470 fillReadBufferLoop fd is_line is_stream buf b w size = do
472 if bytes == 0 -- buffer full?
473 then return buf{ bufRPtr=0, bufWPtr=w }
476 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
478 res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
479 (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
481 let res' = fromIntegral res
483 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
488 else return buf{ bufRPtr=0, bufWPtr=w }
489 else if res' < bytes && not is_line
490 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
491 else return buf{ bufRPtr=0, bufWPtr=w+res' }
493 foreign import ccall unsafe "__hscore_PrelHandle_read"
494 read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
496 foreign import ccall unsafe "__hscore_PrelHandle_read"
497 read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
499 -- ---------------------------------------------------------------------------
502 -- Three handles are allocated during program initialisation. The first
503 -- two manage input or output from the Haskell program's standard input
504 -- or output channel respectively. The third manages output to the
505 -- standard error channel. These handles are initially open.
512 stdin = unsafePerformIO $ do
513 -- ToDo: acquire lock
514 setNonBlockingFD fd_stdin
515 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
516 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
519 stdout = unsafePerformIO $ do
520 -- ToDo: acquire lock
521 -- We don't set non-blocking mode on stdout or sterr, because
522 -- some shells don't recover properly.
523 -- setNonBlockingFD fd_stdout
524 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
525 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
528 stderr = unsafePerformIO $ do
529 -- ToDo: acquire lock
530 -- We don't set non-blocking mode on stdout or sterr, because
531 -- some shells don't recover properly.
532 -- setNonBlockingFD fd_stderr
534 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
536 -- ---------------------------------------------------------------------------
537 -- Opening and Closing Files
540 Computation `openFile file mode' allocates and returns a new, open
541 handle to manage the file `file'. It manages input if `mode'
542 is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
543 and both input and output if mode is `ReadWriteMode'.
545 If the file does not exist and it is opened for output, it should be
546 created as a new file. If `mode' is `WriteMode' and the file
547 already exists, then it should be truncated to zero length. The
548 handle is positioned at the end of the file if `mode' is
549 `AppendMode', and otherwise at the beginning (in which case its
550 internal position is 0).
552 Implementations should enforce, locally to the Haskell process,
553 multiple-reader single-writer locking on files, which is to say that
554 there may either be many handles on the same file which manage input,
555 or just one handle on the file which manages output. If any open or
556 semi-closed handle is managing a file for output, no new handle can be
557 allocated for that file. If any open or semi-closed handle is
558 managing a file for input, new handles can only be allocated if they
559 do not manage output.
561 Two files are the same if they have the same absolute name. An
562 implementation is free to impose stricter conditions.
568 deriving (Eq, Read, Show)
570 addFilePathToIOError fun fp (IOError h iot _ str _)
571 = IOError h iot fun str (Just fp)
573 openFile :: FilePath -> IOMode -> IO Handle
576 (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
579 (\e -> ioError (addFilePathToIOError "openFile" fp e))
581 openFileEx :: FilePath -> IOModeEx -> IO Handle
585 (\e -> ioError (addFilePathToIOError "openFileEx" fp e))
588 openFile' filepath ex_mode =
589 withCString filepath $ \ f ->
594 BinaryMode bmo -> (bmo, True)
595 TextMode tmo -> (tmo, False)
597 oflags1 = case mode of
598 ReadMode -> read_flags
599 WriteMode -> write_flags
600 ReadWriteMode -> rw_flags
601 AppendMode -> append_flags
603 truncate | WriteMode <- mode = True
610 oflags = oflags1 .|. binary_flags
613 -- the old implementation had a complicated series of three opens,
614 -- which is perhaps because we have to be careful not to open
615 -- directories. However, the man pages I've read say that open()
616 -- always returns EISDIR if the file is a directory and was opened
617 -- for writing, so I think we're ok with a single open() here...
618 fd <- fromIntegral `liftM`
619 throwErrnoIfMinus1Retry "openFile"
620 (c_open f (fromIntegral oflags) 0o666)
622 openFd fd Nothing filepath mode binary truncate
623 -- ASSERT: if we just created the file, then openFd won't fail
624 -- (so we don't need to worry about removing the newly created file
625 -- in the event of an error).
628 std_flags = o_NONBLOCK .|. o_NOCTTY
629 output_flags = std_flags .|. o_CREAT
630 read_flags = std_flags .|. o_RDONLY
631 write_flags = output_flags .|. o_WRONLY
632 rw_flags = output_flags .|. o_RDWR
633 append_flags = write_flags .|. o_APPEND
635 -- ---------------------------------------------------------------------------
638 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
639 openFd fd mb_fd_type filepath mode binary truncate = do
640 -- turn on non-blocking mode
643 let (ha_type, write) =
645 ReadMode -> ( ReadHandle, False )
646 WriteMode -> ( WriteHandle, True )
647 ReadWriteMode -> ( ReadWriteHandle, True )
648 AppendMode -> ( AppendHandle, True )
650 -- open() won't tell us if it was a directory if we only opened for
651 -- reading, so check again.
656 let is_stream = fd_type == Stream
659 ioException (IOError Nothing InappropriateType "openFile"
660 "is a directory" Nothing)
663 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
664 | otherwise -> mkFileHandle fd is_stream filepath ha_type binary
666 -- regular files need to be locked
668 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
670 ioException (IOError Nothing ResourceBusy "openFile"
671 "file is locked" Nothing)
673 -- truncate the file if necessary
674 when truncate (fileTruncate filepath)
676 mkFileHandle fd is_stream filepath ha_type binary
679 fdToHandle :: FD -> IO Handle
682 let fd_str = "<file descriptor: " ++ show fd ++ ">"
683 openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
685 foreign import ccall unsafe "lockFile"
686 lockFile :: CInt -> CInt -> CInt -> IO CInt
688 foreign import ccall unsafe "unlockFile"
689 unlockFile :: CInt -> IO CInt
691 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
693 mkStdHandle fd filepath ha_type buf bmode = do
694 spares <- newIORef BufferListNil
695 newFileHandle stdHandleFinalizer
696 (Handle__ { haFD = fd,
698 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
700 haBufferMode = bmode,
701 haFilePath = filepath,
704 haOtherSide = Nothing
707 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
708 mkFileHandle fd is_stream filepath ha_type binary = do
709 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
710 spares <- newIORef BufferListNil
711 newFileHandle handleFinalizer
712 (Handle__ { haFD = fd,
715 haIsStream = is_stream,
716 haBufferMode = bmode,
717 haFilePath = filepath,
720 haOtherSide = Nothing
723 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
724 mkDuplexHandle fd is_stream filepath binary = do
725 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
726 w_spares <- newIORef BufferListNil
728 Handle__ { haFD = fd,
729 haType = WriteHandle,
731 haIsStream = is_stream,
732 haBufferMode = w_bmode,
733 haFilePath = filepath,
735 haBuffers = w_spares,
736 haOtherSide = Nothing
738 write_side <- newMVar w_handle_
740 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
741 r_spares <- newIORef BufferListNil
743 Handle__ { haFD = fd,
746 haIsStream = is_stream,
747 haBufferMode = r_bmode,
748 haFilePath = filepath,
750 haBuffers = r_spares,
751 haOtherSide = Just write_side
753 read_side <- newMVar r_handle_
755 addMVarFinalizer read_side (handleFinalizer read_side)
756 return (DuplexHandle read_side write_side)
759 initBufferState ReadHandle = ReadBuffer
760 initBufferState _ = WriteBuffer
762 -- ---------------------------------------------------------------------------
765 -- Computation `hClose hdl' makes handle `hdl' closed. Before the
766 -- computation finishes, any items buffered for output and not already
767 -- sent to the operating system are flushed as for `hFlush'.
769 -- For a duplex handle, we close&flush the write side, and just close
772 hClose :: Handle -> IO ()
773 hClose h@(FileHandle m) = hClose' h m
774 hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
776 hClose' h m = withHandle__' "hClose" h m $ hClose_help
778 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
779 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
780 -- then closed immediately. We have to be careful with DuplexHandles
781 -- though: we have to leave the closing to the finalizer in that case,
782 -- because the write side may still be in use.
783 hClose_help :: Handle__ -> IO Handle__
784 hClose_help handle_ =
785 case haType handle_ of
786 ClosedHandle -> return handle_
788 let fd = haFD handle_
789 c_fd = fromIntegral fd
791 flushWriteBufferOnly handle_
793 -- close the file descriptor, but not when this is the read
794 -- side of a duplex handle, and not when this is one of the
796 case haOtherSide handle_ of
798 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
799 throwErrnoIfMinus1Retry_ "hClose"
800 #ifdef mingw32_TARGET_OS
801 (closeFd (haIsStream handle_) c_fd)
807 -- free the spare buffers
808 writeIORef (haBuffers handle_) BufferListNil
813 -- we must set the fd to -1, because the finalizer is going
814 -- to run eventually and try to close/unlock it.
815 return (handle_{ haFD = -1,
816 haType = ClosedHandle
819 -----------------------------------------------------------------------------
820 -- Detecting the size of a file
822 -- For a handle `hdl' which attached to a physical file, `hFileSize
823 -- hdl' returns the size of `hdl' in terms of the number of items
824 -- which can be read from `hdl'.
826 hFileSize :: Handle -> IO Integer
828 withHandle_ "hFileSize" handle $ \ handle_ -> do
829 case haType handle_ of
830 ClosedHandle -> ioe_closedHandle
831 SemiClosedHandle -> ioe_closedHandle
832 _ -> do flushWriteBufferOnly handle_
833 r <- fdFileSize (haFD handle_)
836 else ioException (IOError Nothing InappropriateType "hFileSize"
837 "not a regular file" Nothing)
839 -- ---------------------------------------------------------------------------
840 -- Detecting the End of Input
842 -- For a readable handle `hdl', `hIsEOF hdl' returns
843 -- `True' if no further input can be taken from `hdl' or for a
844 -- physical file, if the current I/O position is equal to the length of
845 -- the file. Otherwise, it returns `False'.
847 hIsEOF :: Handle -> IO Bool
850 (do hLookAhead handle; return False)
851 (\e -> if isEOFError e then return True else ioError e)
856 -- ---------------------------------------------------------------------------
859 -- hLookahead returns the next character from the handle without
860 -- removing it from the input buffer, blocking until a character is
863 hLookAhead :: Handle -> IO Char
864 hLookAhead handle = do
865 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
866 let ref = haBuffer handle_
868 is_line = haBufferMode handle_ == LineBuffering
871 -- fill up the read buffer if necessary
872 new_buf <- if bufferEmpty buf
873 then fillReadBuffer fd is_line (haIsStream handle_) buf
876 writeIORef ref new_buf
878 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
881 -- ---------------------------------------------------------------------------
882 -- Buffering Operations
884 -- Three kinds of buffering are supported: line-buffering,
885 -- block-buffering or no-buffering. See GHC.IOBase for definition and
886 -- further explanation of what the type represent.
888 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
889 -- handle hdl on subsequent reads and writes.
891 -- * If mode is LineBuffering, line-buffering should be enabled if possible.
893 -- * If mode is `BlockBuffering size', then block-buffering
894 -- should be enabled if possible. The size of the buffer is n items
895 -- if size is `Just n' and is otherwise implementation-dependent.
897 -- * If mode is NoBuffering, then buffering is disabled if possible.
899 -- If the buffer mode is changed from BlockBuffering or
900 -- LineBuffering to NoBuffering, then any items in the output
901 -- buffer are written to the device, and any items in the input buffer
902 -- are discarded. The default buffering mode when a handle is opened
903 -- is implementation-dependent and may depend on the object which is
904 -- attached to that handle.
906 hSetBuffering :: Handle -> BufferMode -> IO ()
907 hSetBuffering handle mode =
908 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
909 case haType handle_ of
910 ClosedHandle -> ioe_closedHandle
913 - we flush the old buffer regardless of whether
914 the new buffer could fit the contents of the old buffer
916 - allow a handle's buffering to change even if IO has
917 occurred (ANSI C spec. does not allow this, nor did
918 the previous implementation of IO.hSetBuffering).
919 - a non-standard extension is to allow the buffering
920 of semi-closed handles to change [sof 6/98]
924 let state = initBufferState (haType handle_)
927 -- we always have a 1-character read buffer for
928 -- unbuffered handles: it's needed to
929 -- support hLookAhead.
930 NoBuffering -> allocateBuffer 1 ReadBuffer
931 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
932 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
933 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
934 | otherwise -> allocateBuffer n state
935 writeIORef (haBuffer handle_) new_buf
937 -- for input terminals we need to put the terminal into
938 -- cooked or raw mode depending on the type of buffering.
939 is_tty <- fdIsTTY (haFD handle_)
940 when (is_tty && isReadableHandleType (haType handle_)) $
942 NoBuffering -> setCooked (haFD handle_) False
943 _ -> setCooked (haFD handle_) True
945 -- throw away spare buffers, they might be the wrong size
946 writeIORef (haBuffers handle_) BufferListNil
948 return (handle_{ haBufferMode = mode })
950 -- -----------------------------------------------------------------------------
953 -- The action `hFlush hdl' causes any items buffered for output
954 -- in handle `hdl' to be sent immediately to the operating
957 hFlush :: Handle -> IO ()
959 wantWritableHandle "hFlush" handle $ \ handle_ -> do
960 buf <- readIORef (haBuffer handle_)
961 if bufferIsWritable buf && not (bufferEmpty buf)
962 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
963 writeIORef (haBuffer handle_) flushed_buf
967 -- -----------------------------------------------------------------------------
968 -- Repositioning Handles
970 data HandlePosn = HandlePosn Handle HandlePosition
972 instance Eq HandlePosn where
973 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
975 instance Show HandlePosn where
976 showsPrec p (HandlePosn h pos) =
977 showsPrec p h . showString " at position " . shows pos
979 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
980 -- We represent it as an Integer on the Haskell side, but
981 -- cheat slightly in that hGetPosn calls upon a C helper
982 -- that reports the position back via (merely) an Int.
983 type HandlePosition = Integer
985 -- Computation `hGetPosn hdl' returns the current I/O position of
986 -- `hdl' as an abstract position. Computation `hSetPosn p' sets the
987 -- position of `hdl' to a previously obtained position `p'.
989 hGetPosn :: Handle -> IO HandlePosn
992 return (HandlePosn handle posn)
994 hSetPosn :: HandlePosn -> IO ()
995 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
997 -- ---------------------------------------------------------------------------
1001 The action `hSeek hdl mode i' sets the position of handle
1002 `hdl' depending on `mode'. If `mode' is
1004 * AbsoluteSeek - The position of `hdl' is set to `i'.
1005 * RelativeSeek - The position of `hdl' is set to offset `i' from
1006 the current position.
1007 * SeekFromEnd - The position of `hdl' is set to offset `i' from
1008 the end of the file.
1010 Some handles may not be seekable (see `hIsSeekable'), or only
1011 support a subset of the possible positioning operations (e.g. it may
1012 only be possible to seek to the end of a tape, or to a positive
1013 offset from the beginning or current position).
1015 It is not possible to set a negative I/O position, or for a physical
1016 file, an I/O position beyond the current end-of-file.
1019 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1020 seeking at or past EOF.
1022 - we possibly deviate from the report on the issue of seeking within
1023 the buffer and whether to flush it or not. The report isn't exactly
1027 data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
1028 deriving (Eq, Ord, Ix, Enum, Read, Show)
1030 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1031 hSeek handle mode offset =
1032 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1034 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1036 let ref = haBuffer handle_
1037 buf <- readIORef ref
1043 throwErrnoIfMinus1Retry_ "hSeek"
1044 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1047 whence = case mode of
1048 AbsoluteSeek -> sEEK_SET
1049 RelativeSeek -> sEEK_CUR
1050 SeekFromEnd -> sEEK_END
1052 if bufferIsWritable buf
1053 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1054 writeIORef ref new_buf
1058 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1059 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1062 new_buf <- flushReadBuffer (haFD handle_) buf
1063 writeIORef ref new_buf
1067 hTell :: Handle -> IO Integer
1069 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1071 #if defined(mingw32_TARGET_OS)
1072 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1073 -- so we can't easily calculate the file position using the
1074 -- current buffer size. Just flush instead.
1077 let fd = fromIntegral (haFD handle_)
1078 posn <- fromIntegral `liftM`
1079 throwErrnoIfMinus1Retry "hGetPosn"
1080 (c_lseek fd 0 sEEK_CUR)
1082 let ref = haBuffer handle_
1083 buf <- readIORef ref
1086 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1087 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1089 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1090 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1094 -- -----------------------------------------------------------------------------
1095 -- Handle Properties
1097 -- A number of operations return information about the properties of a
1098 -- handle. Each of these operations returns `True' if the handle has
1099 -- the specified property, and `False' otherwise.
1101 hIsOpen :: Handle -> IO Bool
1103 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1104 case haType handle_ of
1105 ClosedHandle -> return False
1106 SemiClosedHandle -> return False
1109 hIsClosed :: Handle -> IO Bool
1111 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1112 case haType handle_ of
1113 ClosedHandle -> return True
1116 {- not defined, nor exported, but mentioned
1117 here for documentation purposes:
1119 hSemiClosed :: Handle -> IO Bool
1123 return (not (ho || hc))
1126 hIsReadable :: Handle -> IO Bool
1127 hIsReadable (DuplexHandle _ _) = return True
1128 hIsReadable handle =
1129 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1130 case haType handle_ of
1131 ClosedHandle -> ioe_closedHandle
1132 SemiClosedHandle -> ioe_closedHandle
1133 htype -> return (isReadableHandleType htype)
1135 hIsWritable :: Handle -> IO Bool
1136 hIsWritable (DuplexHandle _ _) = return False
1137 hIsWritable handle =
1138 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1139 case haType handle_ of
1140 ClosedHandle -> ioe_closedHandle
1141 SemiClosedHandle -> ioe_closedHandle
1142 htype -> return (isWritableHandleType htype)
1144 -- Querying how a handle buffers its data:
1146 hGetBuffering :: Handle -> IO BufferMode
1147 hGetBuffering handle =
1148 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1149 case haType handle_ of
1150 ClosedHandle -> ioe_closedHandle
1152 -- We're being non-standard here, and allow the buffering
1153 -- of a semi-closed handle to be queried. -- sof 6/98
1154 return (haBufferMode handle_) -- could be stricter..
1156 hIsSeekable :: Handle -> IO Bool
1157 hIsSeekable handle =
1158 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1159 case haType handle_ of
1160 ClosedHandle -> ioe_closedHandle
1161 SemiClosedHandle -> ioe_closedHandle
1162 AppendHandle -> return False
1163 _ -> do t <- fdType (haFD handle_)
1164 return (t == RegularFile
1166 || tEXT_MODE_SEEK_ALLOWED))
1168 -- -----------------------------------------------------------------------------
1169 -- Changing echo status
1171 -- Non-standard GHC extension is to allow the echoing status
1172 -- of a handles connected to terminals to be reconfigured:
1174 hSetEcho :: Handle -> Bool -> IO ()
1175 hSetEcho handle on = do
1176 isT <- hIsTerminalDevice handle
1180 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1181 case haType handle_ of
1182 ClosedHandle -> ioe_closedHandle
1183 _ -> setEcho (haFD handle_) on
1185 hGetEcho :: Handle -> IO Bool
1186 hGetEcho handle = do
1187 isT <- hIsTerminalDevice handle
1191 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1192 case haType handle_ of
1193 ClosedHandle -> ioe_closedHandle
1194 _ -> getEcho (haFD handle_)
1196 hIsTerminalDevice :: Handle -> IO Bool
1197 hIsTerminalDevice handle = do
1198 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1199 case haType handle_ of
1200 ClosedHandle -> ioe_closedHandle
1201 _ -> fdIsTTY (haFD handle_)
1203 -- -----------------------------------------------------------------------------
1206 -- | On Windows, reading a file in text mode (which is the default) will
1207 -- translate CRLF to LF, and writing will translate LF to CRLF. This
1208 -- is usually what you want with text files. With binary files this is
1209 -- undesirable; also, as usual under Microsoft operating systems, text
1210 -- mode treats control-Z as EOF. Setting binary mode using
1211 -- 'hSetBinaryMode' turns off all special treatment of end-of-line and
1212 -- end-of-file characters.
1214 hSetBinaryMode :: Handle -> Bool -> IO ()
1215 hSetBinaryMode handle bin =
1216 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1217 do throwErrnoIfMinus1_ "hSetBinaryMode"
1218 (setmode (fromIntegral (haFD handle_)) bin)
1219 return handle_{haIsBin=bin}
1221 foreign import ccall unsafe "__hscore_setmode"
1222 setmode :: CInt -> Bool -> IO CInt
1224 -- -----------------------------------------------------------------------------
1225 -- Duplicating a Handle
1227 -- |Returns a duplicate of the original handle, with its own buffer
1228 -- and file pointer. The original handle's buffer is flushed, including
1229 -- discarding any input data, before the handle is duplicated.
1231 hDuplicate :: Handle -> IO Handle
1232 hDuplicate h@(FileHandle m) = do
1233 new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1234 new_m <- newMVar new_h_
1235 return (FileHandle new_m)
1236 hDuplicate h@(DuplexHandle r w) = do
1237 new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1238 new_w <- newMVar new_w_
1239 new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1240 new_r <- newMVar new_r_
1241 return (DuplexHandle new_r new_w)
1243 dupHandle_ other_side h_ = do
1244 -- flush the buffer first, so we don't have to copy its contents
1246 new_fd <- c_dup (fromIntegral (haFD h_))
1247 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1248 ioref <- newIORef buffer
1249 ioref_buffers <- newIORef BufferListNil
1251 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1253 haBuffers = ioref_buffers,
1254 haOtherSide = other_side }
1255 return (h_, new_handle_)
1257 -- -----------------------------------------------------------------------------
1258 -- Replacing a Handle
1261 Makes the second handle a duplicate of the first handle. The second
1262 handle will be closed first, if it is not already.
1264 This can be used to retarget the standard Handles, for example:
1266 > do h <- openFile "mystdout" WriteMode
1267 > hDuplicateTo h stdout
1270 hDuplicateTo :: Handle -> Handle -> IO ()
1271 hDuplicateTo h1@(FileHandle m1) h2@(FileHandle m2) = do
1272 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1273 _ <- hClose_help h2_
1274 withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1275 hDuplicateTo h1@(DuplexHandle r1 w1) h2@(DuplexHandle r2 w2) = do
1276 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1277 _ <- hClose_help w2_
1278 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1279 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1280 _ <- hClose_help r2_
1281 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1283 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1284 "handles are incompatible" Nothing)
1286 -- ---------------------------------------------------------------------------
1290 puts :: String -> IO ()
1291 puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
1295 -- -----------------------------------------------------------------------------
1296 -- wrappers to platform-specific constants:
1298 foreign import ccall unsafe "__hscore_supportsTextMode"
1299 tEXT_MODE_SEEK_ALLOWED :: Bool
1301 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1302 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1303 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1304 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt