1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
6 -- -----------------------------------------------------------------------------
7 -- $Id: Handle.hs,v 1.6 2002/03/26 17:06:32 simonmar Exp $
9 -- (c) The University of Glasgow, 1994-2001
11 -- This module defines the basic operations on I/O "handles".
14 withHandle, withHandle', withHandle_,
15 wantWritableHandle, wantReadableHandle, wantSeekableHandle,
17 newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
18 flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
19 read_off, read_off_ba,
20 write_off, write_off_ba,
22 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
24 stdin, stdout, stderr,
25 IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
26 hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
31 HandlePosn(..), hGetPosn, hSetPosn,
32 SeekMode(..), hSeek, hTell,
34 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
35 hSetEcho, hGetEcho, hIsTerminalDevice,
48 import System.IO.Error
55 import GHC.Read ( Read )
60 import GHC.Num ( Integer(..), Num(..) )
62 import GHC.Real ( toInteger )
66 -- -----------------------------------------------------------------------------
69 -- hWaitForInput blocks (should use a timeout)
71 -- unbuffered hGetLine is a bit dodgy
73 -- hSetBuffering: can't change buffering on a stream,
74 -- when the read buffer is non-empty? (no way to flush the buffer)
76 -- ---------------------------------------------------------------------------
77 -- Are files opened by default in text or binary mode, if the user doesn't
80 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
82 -- ---------------------------------------------------------------------------
83 -- Creating a new handle
85 newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
86 newFileHandle finalizer hc = do
88 addMVarFinalizer m (finalizer m)
91 -- ---------------------------------------------------------------------------
92 -- Working with Handles
95 In the concurrent world, handles are locked during use. This is done
96 by wrapping an MVar around the handle which acts as a mutex over
97 operations on the handle.
99 To avoid races, we use the following bracketing operations. The idea
100 is to obtain the lock, do some operation and replace the lock again,
101 whether the operation succeeded or failed. We also want to handle the
102 case where the thread receives an exception while processing the IO
103 operation: in these cases we also want to relinquish the lock.
105 There are three versions of @withHandle@: corresponding to the three
106 possible combinations of:
108 - the operation may side-effect the handle
109 - the operation may return a result
111 If the operation generates an error or an exception is raised, the
112 original handle is always replaced [ this is the case at the moment,
113 but we might want to revisit this in the future --SDM ].
116 {-# INLINE withHandle #-}
117 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
118 withHandle fun h@(FileHandle m) act = withHandle' fun h m act
119 withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
121 withHandle' :: String -> Handle -> MVar Handle__
122 -> (Handle__ -> IO (Handle__,a)) -> IO a
123 withHandle' fun h m act =
126 checkBufferInvariants h_
127 (h',v) <- catchException (act h_)
128 (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
129 checkBufferInvariants h'
133 {-# INLINE withHandle_ #-}
134 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
135 withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
136 withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
138 withHandle_' fun h m act =
141 checkBufferInvariants h_
142 v <- catchException (act h_)
143 (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
144 checkBufferInvariants h_
148 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
149 withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
150 withAllHandles__ fun h@(DuplexHandle r w) act = do
151 withHandle__' fun h r act
152 withHandle__' fun h w act
154 withHandle__' fun h m act =
157 checkBufferInvariants h_
158 h' <- catchException (act h_)
159 (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
160 checkBufferInvariants h'
164 augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
165 = IOException (IOError (Just h) iot fun str filepath)
166 where filepath | Just _ <- fp = fp
167 | otherwise = Just (haFilePath h_)
168 augmentIOError other_exception _ _ _
171 -- ---------------------------------------------------------------------------
172 -- Wrapper for write operations.
174 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
175 wantWritableHandle fun h@(FileHandle m) act
176 = wantWritableHandle' fun h m act
177 wantWritableHandle fun h@(DuplexHandle _ m) act
178 = wantWritableHandle' fun h m act
179 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
182 :: String -> Handle -> MVar Handle__
183 -> (Handle__ -> IO a) -> IO a
184 wantWritableHandle' fun h m act
185 = withHandle_' fun h m (checkWritableHandle act)
187 checkWritableHandle act handle_
188 = case haType handle_ of
189 ClosedHandle -> ioe_closedHandle
190 SemiClosedHandle -> ioe_closedHandle
191 ReadHandle -> ioe_notWritable
192 ReadWriteHandle -> do
193 let ref = haBuffer handle_
196 if not (bufferIsWritable buf)
197 then do b <- flushReadBuffer (haFD handle_) buf
198 return b{ bufState=WriteBuffer }
200 writeIORef ref new_buf
202 _other -> act handle_
204 -- ---------------------------------------------------------------------------
205 -- Wrapper for read operations.
207 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
208 wantReadableHandle fun h@(FileHandle m) act
209 = wantReadableHandle' fun h m act
210 wantReadableHandle fun h@(DuplexHandle m _) act
211 = wantReadableHandle' fun h m act
212 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
215 :: String -> Handle -> MVar Handle__
216 -> (Handle__ -> IO a) -> IO a
217 wantReadableHandle' fun h m act
218 = withHandle_' fun h m (checkReadableHandle act)
220 checkReadableHandle act handle_ =
221 case haType handle_ of
222 ClosedHandle -> ioe_closedHandle
223 SemiClosedHandle -> ioe_closedHandle
224 AppendHandle -> ioe_notReadable
225 WriteHandle -> ioe_notReadable
226 ReadWriteHandle -> do
227 let ref = haBuffer handle_
229 when (bufferIsWritable buf) $ do
230 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
231 writeIORef ref new_buf{ bufState=ReadBuffer }
233 _other -> act handle_
235 -- ---------------------------------------------------------------------------
236 -- Wrapper for seek operations.
238 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
239 wantSeekableHandle fun h@(DuplexHandle _ _) _act =
240 ioException (IOError (Just h) IllegalOperation fun
241 "handle is not seekable" Nothing)
242 wantSeekableHandle fun h@(FileHandle m) act =
243 withHandle_' fun h m (checkSeekableHandle act)
245 checkSeekableHandle act handle_ =
246 case haType handle_ of
247 ClosedHandle -> ioe_closedHandle
248 SemiClosedHandle -> ioe_closedHandle
249 AppendHandle -> ioe_notSeekable
250 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
251 | otherwise -> ioe_notSeekable_notBin
253 -- -----------------------------------------------------------------------------
256 ioe_closedHandle, ioe_EOF,
257 ioe_notReadable, ioe_notWritable,
258 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
260 ioe_closedHandle = ioException
261 (IOError Nothing IllegalOperation ""
262 "handle is closed" Nothing)
263 ioe_EOF = ioException
264 (IOError Nothing EOF "" "" Nothing)
265 ioe_notReadable = ioException
266 (IOError Nothing IllegalOperation ""
267 "handle is not open for reading" Nothing)
268 ioe_notWritable = ioException
269 (IOError Nothing IllegalOperation ""
270 "handle is not open for writing" Nothing)
271 ioe_notSeekable = ioException
272 (IOError Nothing IllegalOperation ""
273 "handle is not seekable" Nothing)
274 ioe_notSeekable_notBin = ioException
275 (IOError Nothing IllegalOperation ""
276 "seek operations on text-mode handles are not allowed on this platform"
279 ioe_bufsiz :: Int -> IO a
280 ioe_bufsiz n = ioException
281 (IOError Nothing InvalidArgument "hSetBuffering"
282 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
283 -- 9 => should be parens'ified.
285 -- -----------------------------------------------------------------------------
288 -- For a duplex handle, we arrange that the read side points to the write side
289 -- (and hence keeps it alive if the read side is alive). This is done by
290 -- having the haOtherSide field of the read side point to the read side.
291 -- The finalizer is then placed on the write side, and the handle only gets
292 -- finalized once, when both sides are no longer required.
294 stdHandleFinalizer :: MVar Handle__ -> IO ()
295 stdHandleFinalizer m = do
297 flushWriteBufferOnly h_
299 handleFinalizer :: MVar Handle__ -> IO ()
300 handleFinalizer m = do
302 flushWriteBufferOnly h_
303 let fd = fromIntegral (haFD h_)
306 #ifdef mingw32_TARGET_OS
307 (closeFd (haIsStream h_) fd >> return ())
309 (c_close fd >> return ())
313 -- ---------------------------------------------------------------------------
314 -- Grimy buffer operations
317 checkBufferInvariants h_ = do
318 let ref = haBuffer h_
319 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
324 && ( r /= w || (r == 0 && w == 0) )
325 && ( state /= WriteBuffer || r == 0 )
326 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
328 then error "buffer invariant violation"
331 checkBufferInvariants h_ = return ()
334 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
335 newEmptyBuffer b state size
336 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
338 allocateBuffer :: Int -> BufferState -> IO Buffer
339 allocateBuffer sz@(I# size) state = IO $ \s ->
340 case newByteArray# size s of { (# s, b #) ->
341 (# s, newEmptyBuffer b state sz #) }
343 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
344 writeCharIntoBuffer slab (I# off) (C# c)
345 = IO $ \s -> case writeCharArray# slab off c s of
346 s -> (# s, I# (off +# 1#) #)
348 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
349 readCharFromBuffer slab (I# off)
350 = IO $ \s -> case readCharArray# slab off s of
351 (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
353 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
354 getBuffer fd state = do
355 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
356 ioref <- newIORef buffer
360 | is_tty = LineBuffering
361 | otherwise = BlockBuffering Nothing
363 return (ioref, buffer_mode)
365 mkUnBuffer :: IO (IORef Buffer)
367 buffer <- allocateBuffer 1 ReadBuffer
370 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
371 flushWriteBufferOnly :: Handle__ -> IO ()
372 flushWriteBufferOnly h_ = do
376 new_buf <- if bufferIsWritable buf
377 then flushWriteBuffer fd (haIsStream h_) buf
379 writeIORef ref new_buf
381 -- flushBuffer syncs the file with the buffer, including moving the
382 -- file pointer backwards in the case of a read buffer.
383 flushBuffer :: Handle__ -> IO ()
385 let ref = haBuffer h_
390 ReadBuffer -> flushReadBuffer (haFD h_) buf
391 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
393 writeIORef ref flushed_buf
395 -- When flushing a read buffer, we seek backwards by the number of
396 -- characters in the buffer. The file descriptor must therefore be
397 -- seekable: attempting to flush the read buffer on an unseekable
398 -- handle is not allowed.
400 flushReadBuffer :: FD -> Buffer -> IO Buffer
401 flushReadBuffer fd buf
402 | bufferEmpty buf = return buf
404 let off = negate (bufWPtr buf - bufRPtr buf)
406 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
408 throwErrnoIfMinus1Retry "flushReadBuffer"
409 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
410 return buf{ bufWPtr=0, bufRPtr=0 }
412 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
413 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
416 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
419 then return (buf{ bufRPtr=0, bufWPtr=0 })
421 res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
422 (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
423 (fromIntegral bytes))
425 let res' = fromIntegral res
427 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
428 else return buf{ bufRPtr=0, bufWPtr=0 }
430 foreign import ccall unsafe "__hscore_PrelHandle_write"
431 write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
433 foreign import ccall unsafe "__hscore_PrelHandle_write"
434 write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
436 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
437 fillReadBuffer fd is_line is_stream
438 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
439 -- buffer better be empty:
440 assert (r == 0 && w == 0) $ do
441 fillReadBufferLoop fd is_line is_stream buf b w size
443 -- For a line buffer, we just get the first chunk of data to arrive,
444 -- and don't wait for the whole buffer to be full (but we *do* wait
445 -- until some data arrives). This isn't really line buffering, but it
446 -- appears to be what GHC has done for a long time, and I suspect it
447 -- is more useful than line buffering in most cases.
449 fillReadBufferLoop fd is_line is_stream buf b w size = do
451 if bytes == 0 -- buffer full?
452 then return buf{ bufRPtr=0, bufWPtr=w }
455 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
457 res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
458 (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
460 let res' = fromIntegral res
462 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
467 else return buf{ bufRPtr=0, bufWPtr=w }
468 else if res' < bytes && not is_line
469 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
470 else return buf{ bufRPtr=0, bufWPtr=w+res' }
472 foreign import ccall unsafe "__hscore_PrelHandle_read"
473 read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
475 foreign import ccall unsafe "__hscore_PrelHandle_read"
476 read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
478 -- ---------------------------------------------------------------------------
481 -- Three handles are allocated during program initialisation. The first
482 -- two manage input or output from the Haskell program's standard input
483 -- or output channel respectively. The third manages output to the
484 -- standard error channel. These handles are initially open.
491 stdin = unsafePerformIO $ do
492 -- ToDo: acquire lock
493 setNonBlockingFD fd_stdin
494 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
495 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
498 stdout = unsafePerformIO $ do
499 -- ToDo: acquire lock
500 -- We don't set non-blocking mode on stdout or sterr, because
501 -- some shells don't recover properly.
502 -- setNonBlockingFD fd_stdout
503 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
504 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
507 stderr = unsafePerformIO $ do
508 -- ToDo: acquire lock
509 -- We don't set non-blocking mode on stdout or sterr, because
510 -- some shells don't recover properly.
511 -- setNonBlockingFD fd_stderr
513 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
515 -- ---------------------------------------------------------------------------
516 -- Opening and Closing Files
519 Computation `openFile file mode' allocates and returns a new, open
520 handle to manage the file `file'. It manages input if `mode'
521 is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
522 and both input and output if mode is `ReadWriteMode'.
524 If the file does not exist and it is opened for output, it should be
525 created as a new file. If `mode' is `WriteMode' and the file
526 already exists, then it should be truncated to zero length. The
527 handle is positioned at the end of the file if `mode' is
528 `AppendMode', and otherwise at the beginning (in which case its
529 internal position is 0).
531 Implementations should enforce, locally to the Haskell process,
532 multiple-reader single-writer locking on files, which is to say that
533 there may either be many handles on the same file which manage input,
534 or just one handle on the file which manages output. If any open or
535 semi-closed handle is managing a file for output, no new handle can be
536 allocated for that file. If any open or semi-closed handle is
537 managing a file for input, new handles can only be allocated if they
538 do not manage output.
540 Two files are the same if they have the same absolute name. An
541 implementation is free to impose stricter conditions.
544 data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
545 deriving (Eq, Ord, Ix, Enum, Read, Show)
550 deriving (Eq, Read, Show)
552 addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
553 = IOException (IOError h iot fun str (Just fp))
554 addFilePathToIOError _ _ other_exception
557 openFile :: FilePath -> IOMode -> IO Handle
560 (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
563 (\e -> throw (addFilePathToIOError "openFile" fp e))
565 openFileEx :: FilePath -> IOModeEx -> IO Handle
569 (\e -> throw (addFilePathToIOError "openFileEx" fp e))
572 openFile' filepath ex_mode =
573 withCString filepath $ \ f ->
578 BinaryMode bmo -> (bmo, True)
579 TextMode tmo -> (tmo, False)
581 oflags1 = case mode of
582 ReadMode -> read_flags
583 WriteMode -> write_flags
584 ReadWriteMode -> rw_flags
585 AppendMode -> append_flags
587 truncate | WriteMode <- mode = True
594 oflags = oflags1 .|. binary_flags
597 -- the old implementation had a complicated series of three opens,
598 -- which is perhaps because we have to be careful not to open
599 -- directories. However, the man pages I've read say that open()
600 -- always returns EISDIR if the file is a directory and was opened
601 -- for writing, so I think we're ok with a single open() here...
602 fd <- fromIntegral `liftM`
603 throwErrnoIfMinus1Retry "openFile"
604 (c_open f (fromIntegral oflags) 0o666)
606 openFd fd Nothing filepath mode binary truncate
607 -- ASSERT: if we just created the file, then openFd won't fail
608 -- (so we don't need to worry about removing the newly created file
609 -- in the event of an error).
612 std_flags = o_NONBLOCK .|. o_NOCTTY
613 output_flags = std_flags .|. o_CREAT
614 read_flags = std_flags .|. o_RDONLY
615 write_flags = output_flags .|. o_WRONLY
616 rw_flags = output_flags .|. o_RDWR
617 append_flags = write_flags .|. o_APPEND
619 -- ---------------------------------------------------------------------------
622 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
623 openFd fd mb_fd_type filepath mode binary truncate = do
624 -- turn on non-blocking mode
627 let (ha_type, write) =
629 ReadMode -> ( ReadHandle, False )
630 WriteMode -> ( WriteHandle, True )
631 ReadWriteMode -> ( ReadWriteHandle, True )
632 AppendMode -> ( AppendHandle, True )
634 -- open() won't tell us if it was a directory if we only opened for
635 -- reading, so check again.
640 let is_stream = fd_type == Stream
643 ioException (IOError Nothing InappropriateType "openFile"
644 "is a directory" Nothing)
647 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
648 | otherwise -> mkFileHandle fd is_stream filepath ha_type binary
650 -- regular files need to be locked
652 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
654 ioException (IOError Nothing ResourceBusy "openFile"
655 "file is locked" Nothing)
657 -- truncate the file if necessary
658 when truncate (fileTruncate filepath)
660 mkFileHandle fd is_stream filepath ha_type binary
663 foreign import ccall unsafe "lockFile"
664 lockFile :: CInt -> CInt -> CInt -> IO CInt
666 foreign import ccall unsafe "unlockFile"
667 unlockFile :: CInt -> IO CInt
669 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
671 mkStdHandle fd filepath ha_type buf bmode = do
672 spares <- newIORef BufferListNil
673 newFileHandle stdHandleFinalizer
674 (Handle__ { haFD = fd,
676 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
678 haBufferMode = bmode,
679 haFilePath = filepath,
682 haOtherSide = Nothing
685 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
686 mkFileHandle fd is_stream filepath ha_type binary = do
687 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
688 spares <- newIORef BufferListNil
689 newFileHandle handleFinalizer
690 (Handle__ { haFD = fd,
693 haIsStream = is_stream,
694 haBufferMode = bmode,
695 haFilePath = filepath,
698 haOtherSide = Nothing
701 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
702 mkDuplexHandle fd is_stream filepath binary = do
703 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
704 w_spares <- newIORef BufferListNil
706 Handle__ { haFD = fd,
707 haType = WriteHandle,
709 haIsStream = is_stream,
710 haBufferMode = w_bmode,
711 haFilePath = filepath,
713 haBuffers = w_spares,
714 haOtherSide = Nothing
716 write_side <- newMVar w_handle_
718 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
719 r_spares <- newIORef BufferListNil
721 Handle__ { haFD = fd,
724 haIsStream = is_stream,
725 haBufferMode = r_bmode,
726 haFilePath = filepath,
728 haBuffers = r_spares,
729 haOtherSide = Just write_side
731 read_side <- newMVar r_handle_
733 addMVarFinalizer read_side (handleFinalizer read_side)
734 return (DuplexHandle read_side write_side)
737 initBufferState ReadHandle = ReadBuffer
738 initBufferState _ = WriteBuffer
740 -- ---------------------------------------------------------------------------
743 -- Computation `hClose hdl' makes handle `hdl' closed. Before the
744 -- computation finishes, any items buffered for output and not already
745 -- sent to the operating system are flushed as for `hFlush'.
747 -- For a duplex handle, we close&flush the write side, and just close
750 hClose :: Handle -> IO ()
751 hClose h@(FileHandle m) = hClose' h m
752 hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
754 hClose' h m = withHandle__' "hClose" h m $ hClose_help
756 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
757 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
758 -- then closed immediately. We have to be careful with DuplexHandles
759 -- though: we have to leave the closing to the finalizer in that case,
760 -- because the write side may still be in use.
761 hClose_help :: Handle__ -> IO Handle__
762 hClose_help handle_ =
763 case haType handle_ of
764 ClosedHandle -> return handle_
766 let fd = haFD handle_
767 c_fd = fromIntegral fd
769 flushWriteBufferOnly handle_
771 -- close the file descriptor, but not when this is the read
772 -- side of a duplex handle, and not when this is one of the
774 case haOtherSide handle_ of
776 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
777 throwErrnoIfMinus1Retry_ "hClose"
778 #ifdef mingw32_TARGET_OS
779 (closeFd (haIsStream handle_) c_fd)
785 -- free the spare buffers
786 writeIORef (haBuffers handle_) BufferListNil
791 -- we must set the fd to -1, because the finalizer is going
792 -- to run eventually and try to close/unlock it.
793 return (handle_{ haFD = -1,
794 haType = ClosedHandle
797 -----------------------------------------------------------------------------
798 -- Detecting the size of a file
800 -- For a handle `hdl' which attached to a physical file, `hFileSize
801 -- hdl' returns the size of `hdl' in terms of the number of items
802 -- which can be read from `hdl'.
804 hFileSize :: Handle -> IO Integer
806 withHandle_ "hFileSize" handle $ \ handle_ -> do
807 case haType handle_ of
808 ClosedHandle -> ioe_closedHandle
809 SemiClosedHandle -> ioe_closedHandle
810 _ -> do flushWriteBufferOnly handle_
811 r <- fdFileSize (haFD handle_)
814 else ioException (IOError Nothing InappropriateType "hFileSize"
815 "not a regular file" Nothing)
817 -- ---------------------------------------------------------------------------
818 -- Detecting the End of Input
820 -- For a readable handle `hdl', `hIsEOF hdl' returns
821 -- `True' if no further input can be taken from `hdl' or for a
822 -- physical file, if the current I/O position is equal to the length of
823 -- the file. Otherwise, it returns `False'.
825 hIsEOF :: Handle -> IO Bool
828 (do hLookAhead handle; return False)
829 (\e -> if isEOFError e then return True else throw e)
834 -- ---------------------------------------------------------------------------
837 -- hLookahead returns the next character from the handle without
838 -- removing it from the input buffer, blocking until a character is
841 hLookAhead :: Handle -> IO Char
842 hLookAhead handle = do
843 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
844 let ref = haBuffer handle_
846 is_line = haBufferMode handle_ == LineBuffering
849 -- fill up the read buffer if necessary
850 new_buf <- if bufferEmpty buf
851 then fillReadBuffer fd is_line (haIsStream handle_) buf
854 writeIORef ref new_buf
856 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
859 -- ---------------------------------------------------------------------------
860 -- Buffering Operations
862 -- Three kinds of buffering are supported: line-buffering,
863 -- block-buffering or no-buffering. See GHC.IOBase for definition and
864 -- further explanation of what the type represent.
866 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
867 -- handle hdl on subsequent reads and writes.
869 -- * If mode is LineBuffering, line-buffering should be enabled if possible.
871 -- * If mode is `BlockBuffering size', then block-buffering
872 -- should be enabled if possible. The size of the buffer is n items
873 -- if size is `Just n' and is otherwise implementation-dependent.
875 -- * If mode is NoBuffering, then buffering is disabled if possible.
877 -- If the buffer mode is changed from BlockBuffering or
878 -- LineBuffering to NoBuffering, then any items in the output
879 -- buffer are written to the device, and any items in the input buffer
880 -- are discarded. The default buffering mode when a handle is opened
881 -- is implementation-dependent and may depend on the object which is
882 -- attached to that handle.
884 hSetBuffering :: Handle -> BufferMode -> IO ()
885 hSetBuffering handle mode =
886 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
887 case haType handle_ of
888 ClosedHandle -> ioe_closedHandle
891 - we flush the old buffer regardless of whether
892 the new buffer could fit the contents of the old buffer
894 - allow a handle's buffering to change even if IO has
895 occurred (ANSI C spec. does not allow this, nor did
896 the previous implementation of IO.hSetBuffering).
897 - a non-standard extension is to allow the buffering
898 of semi-closed handles to change [sof 6/98]
902 let state = initBufferState (haType handle_)
905 -- we always have a 1-character read buffer for
906 -- unbuffered handles: it's needed to
907 -- support hLookAhead.
908 NoBuffering -> allocateBuffer 1 ReadBuffer
909 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
910 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
911 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
912 | otherwise -> allocateBuffer n state
913 writeIORef (haBuffer handle_) new_buf
915 -- for input terminals we need to put the terminal into
916 -- cooked or raw mode depending on the type of buffering.
917 is_tty <- fdIsTTY (haFD handle_)
918 when (is_tty && isReadableHandleType (haType handle_)) $
920 NoBuffering -> setCooked (haFD handle_) False
921 _ -> setCooked (haFD handle_) True
923 -- throw away spare buffers, they might be the wrong size
924 writeIORef (haBuffers handle_) BufferListNil
926 return (handle_{ haBufferMode = mode })
928 -- -----------------------------------------------------------------------------
931 -- The action `hFlush hdl' causes any items buffered for output
932 -- in handle `hdl' to be sent immediately to the operating
935 hFlush :: Handle -> IO ()
937 wantWritableHandle "hFlush" handle $ \ handle_ -> do
938 buf <- readIORef (haBuffer handle_)
939 if bufferIsWritable buf && not (bufferEmpty buf)
940 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
941 writeIORef (haBuffer handle_) flushed_buf
945 -- -----------------------------------------------------------------------------
946 -- Repositioning Handles
948 data HandlePosn = HandlePosn Handle HandlePosition
950 instance Eq HandlePosn where
951 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
953 instance Show HandlePosn where
954 showsPrec p (HandlePosn h pos) =
955 showsPrec p h . showString " at position " . shows pos
957 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
958 -- We represent it as an Integer on the Haskell side, but
959 -- cheat slightly in that hGetPosn calls upon a C helper
960 -- that reports the position back via (merely) an Int.
961 type HandlePosition = Integer
963 -- Computation `hGetPosn hdl' returns the current I/O position of
964 -- `hdl' as an abstract position. Computation `hSetPosn p' sets the
965 -- position of `hdl' to a previously obtained position `p'.
967 hGetPosn :: Handle -> IO HandlePosn
970 return (HandlePosn handle posn)
972 hSetPosn :: HandlePosn -> IO ()
973 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
975 -- ---------------------------------------------------------------------------
979 The action `hSeek hdl mode i' sets the position of handle
980 `hdl' depending on `mode'. If `mode' is
982 * AbsoluteSeek - The position of `hdl' is set to `i'.
983 * RelativeSeek - The position of `hdl' is set to offset `i' from
984 the current position.
985 * SeekFromEnd - The position of `hdl' is set to offset `i' from
988 Some handles may not be seekable (see `hIsSeekable'), or only
989 support a subset of the possible positioning operations (e.g. it may
990 only be possible to seek to the end of a tape, or to a positive
991 offset from the beginning or current position).
993 It is not possible to set a negative I/O position, or for a physical
994 file, an I/O position beyond the current end-of-file.
997 - when seeking using `SeekFromEnd', positive offsets (>=0) means
998 seeking at or past EOF.
1000 - we possibly deviate from the report on the issue of seeking within
1001 the buffer and whether to flush it or not. The report isn't exactly
1005 data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
1006 deriving (Eq, Ord, Ix, Enum, Read, Show)
1008 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1009 hSeek handle mode offset =
1010 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1012 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1014 let ref = haBuffer handle_
1015 buf <- readIORef ref
1021 throwErrnoIfMinus1Retry_ "hSeek"
1022 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1025 whence = case mode of
1026 AbsoluteSeek -> sEEK_SET
1027 RelativeSeek -> sEEK_CUR
1028 SeekFromEnd -> sEEK_END
1030 if bufferIsWritable buf
1031 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1032 writeIORef ref new_buf
1036 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1037 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1040 new_buf <- flushReadBuffer (haFD handle_) buf
1041 writeIORef ref new_buf
1045 hTell :: Handle -> IO Integer
1047 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1049 #if defined(mingw32_TARGET_OS)
1050 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1051 -- so we can't easily calculate the file position using the
1052 -- current buffer size. Just flush instead.
1055 let fd = fromIntegral (haFD handle_)
1056 posn <- fromIntegral `liftM`
1057 throwErrnoIfMinus1Retry "hGetPosn"
1058 (c_lseek fd 0 sEEK_CUR)
1060 let ref = haBuffer handle_
1061 buf <- readIORef ref
1064 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1065 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1067 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1068 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1072 -- -----------------------------------------------------------------------------
1073 -- Handle Properties
1075 -- A number of operations return information about the properties of a
1076 -- handle. Each of these operations returns `True' if the handle has
1077 -- the specified property, and `False' otherwise.
1079 hIsOpen :: Handle -> IO Bool
1081 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1082 case haType handle_ of
1083 ClosedHandle -> return False
1084 SemiClosedHandle -> return False
1087 hIsClosed :: Handle -> IO Bool
1089 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1090 case haType handle_ of
1091 ClosedHandle -> return True
1094 {- not defined, nor exported, but mentioned
1095 here for documentation purposes:
1097 hSemiClosed :: Handle -> IO Bool
1101 return (not (ho || hc))
1104 hIsReadable :: Handle -> IO Bool
1105 hIsReadable (DuplexHandle _ _) = return True
1106 hIsReadable handle =
1107 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1108 case haType handle_ of
1109 ClosedHandle -> ioe_closedHandle
1110 SemiClosedHandle -> ioe_closedHandle
1111 htype -> return (isReadableHandleType htype)
1113 hIsWritable :: Handle -> IO Bool
1114 hIsWritable (DuplexHandle _ _) = return False
1115 hIsWritable handle =
1116 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1117 case haType handle_ of
1118 ClosedHandle -> ioe_closedHandle
1119 SemiClosedHandle -> ioe_closedHandle
1120 htype -> return (isWritableHandleType htype)
1122 -- Querying how a handle buffers its data:
1124 hGetBuffering :: Handle -> IO BufferMode
1125 hGetBuffering handle =
1126 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1127 case haType handle_ of
1128 ClosedHandle -> ioe_closedHandle
1130 -- We're being non-standard here, and allow the buffering
1131 -- of a semi-closed handle to be queried. -- sof 6/98
1132 return (haBufferMode handle_) -- could be stricter..
1134 hIsSeekable :: Handle -> IO Bool
1135 hIsSeekable handle =
1136 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1137 case haType handle_ of
1138 ClosedHandle -> ioe_closedHandle
1139 SemiClosedHandle -> ioe_closedHandle
1140 AppendHandle -> return False
1141 _ -> do t <- fdType (haFD handle_)
1142 return (t == RegularFile
1144 || tEXT_MODE_SEEK_ALLOWED))
1146 -- -----------------------------------------------------------------------------
1147 -- Changing echo status
1149 -- Non-standard GHC extension is to allow the echoing status
1150 -- of a handles connected to terminals to be reconfigured:
1152 hSetEcho :: Handle -> Bool -> IO ()
1153 hSetEcho handle on = do
1154 isT <- hIsTerminalDevice handle
1158 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1159 case haType handle_ of
1160 ClosedHandle -> ioe_closedHandle
1161 _ -> setEcho (haFD handle_) on
1163 hGetEcho :: Handle -> IO Bool
1164 hGetEcho handle = do
1165 isT <- hIsTerminalDevice handle
1169 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1170 case haType handle_ of
1171 ClosedHandle -> ioe_closedHandle
1172 _ -> getEcho (haFD handle_)
1174 hIsTerminalDevice :: Handle -> IO Bool
1175 hIsTerminalDevice handle = do
1176 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1177 case haType handle_ of
1178 ClosedHandle -> ioe_closedHandle
1179 _ -> fdIsTTY (haFD handle_)
1181 -- -----------------------------------------------------------------------------
1184 hSetBinaryMode :: Handle -> Bool -> IO ()
1185 hSetBinaryMode handle bin =
1186 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1187 do throwErrnoIfMinus1_ "hSetBinaryMode"
1188 (setmode (fromIntegral (haFD handle_)) bin)
1189 return handle_{haIsBin=bin}
1191 foreign import ccall unsafe "__hscore_setmode"
1192 setmode :: CInt -> Bool -> IO CInt
1194 -- ---------------------------------------------------------------------------
1198 puts :: String -> IO ()
1199 puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
1203 -- -----------------------------------------------------------------------------
1204 -- wrappers to platform-specific constants:
1206 foreign import ccall unsafe "__hscore_supportsTextMode"
1207 tEXT_MODE_SEEK_ALLOWED :: Bool
1209 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1210 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1211 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1212 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt