[project @ 2002-07-02 10:28:54 by simonmar]
[ghc.git] / libraries / base / GHC / Handle.hs
1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
2
3 #undef DEBUG_DUMP
4 #undef DEBUG
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : GHC.Handle
9 -- Copyright : (c) The University of Glasgow, 1994-2001
10 -- License : see libraries/base/LICENSE
11 --
12 -- Maintainer : libraries@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable
15 --
16 -- This module defines the basic operations on I\/O \"handles\".
17 --
18 -----------------------------------------------------------------------------
19
20 module GHC.Handle (
21 withHandle, withHandle', withHandle_,
22 wantWritableHandle, wantReadableHandle, wantSeekableHandle,
23
24 newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
25 flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
26 read_off, read_off_ba,
27 write_off, write_off_ba,
28
29 ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
30
31 stdin, stdout, stderr,
32 IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
33 hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
34 hFlush,
35
36 hClose, hClose_help,
37
38 HandlePosn(..), hGetPosn, hSetPosn,
39 SeekMode(..), hSeek, hTell,
40
41 hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
42 hSetEcho, hGetEcho, hIsTerminalDevice,
43
44 #ifdef DEBUG_DUMP
45 puts,
46 #endif
47
48 ) where
49
50 import Control.Monad
51 import Data.Bits
52 import Data.Maybe
53 import Foreign
54 import Foreign.C
55 import System.IO.Error
56
57 import GHC.Posix
58 import GHC.Real
59
60 import GHC.Arr
61 import GHC.Base
62 import GHC.Read ( Read )
63 import GHC.List
64 import GHC.IOBase
65 import GHC.Exception
66 import GHC.Enum
67 import GHC.Num ( Integer(..), Num(..) )
68 import GHC.Show
69 import GHC.Real ( toInteger )
70
71 import GHC.Conc
72
73 -- -----------------------------------------------------------------------------
74 -- TODO:
75
76 -- hWaitForInput blocks (should use a timeout)
77
78 -- unbuffered hGetLine is a bit dodgy
79
80 -- hSetBuffering: can't change buffering on a stream,
81 -- when the read buffer is non-empty? (no way to flush the buffer)
82
83 -- ---------------------------------------------------------------------------
84 -- Are files opened by default in text or binary mode, if the user doesn't
85 -- specify?
86
87 dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool
88
89 -- ---------------------------------------------------------------------------
90 -- Creating a new handle
91
92 newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
93 newFileHandle finalizer hc = do
94 m <- newMVar hc
95 addMVarFinalizer m (finalizer m)
96 return (FileHandle m)
97
98 -- ---------------------------------------------------------------------------
99 -- Working with Handles
100
101 {-
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.
105
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.
111
112 There are three versions of @withHandle@: corresponding to the three
113 possible combinations of:
114
115 - the operation may side-effect the handle
116 - the operation may return a result
117
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 ].
121 -}
122
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
127
128 withHandle' :: String -> Handle -> MVar Handle__
129 -> (Handle__ -> IO (Handle__,a)) -> IO a
130 withHandle' fun h m act =
131 block $ do
132 h_ <- takeMVar m
133 checkBufferInvariants h_
134 (h',v) <- catchException (act h_)
135 (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
136 checkBufferInvariants h'
137 putMVar m h'
138 return v
139
140 {-# INLINE withHandle_ #-}
141 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
142 withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
143 withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
144
145 withHandle_' fun h m act =
146 block $ do
147 h_ <- takeMVar m
148 checkBufferInvariants h_
149 v <- catchException (act h_)
150 (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
151 checkBufferInvariants h_
152 putMVar m h_
153 return v
154
155 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
156 withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
157 withAllHandles__ fun h@(DuplexHandle r w) act = do
158 withHandle__' fun h r act
159 withHandle__' fun h w act
160
161 withHandle__' fun h m act =
162 block $ do
163 h_ <- takeMVar m
164 checkBufferInvariants h_
165 h' <- catchException (act h_)
166 (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
167 checkBufferInvariants h'
168 putMVar m h'
169 return ()
170
171 augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
172 = IOException (IOError (Just h) iot fun str filepath)
173 where filepath | Just _ <- fp = fp
174 | otherwise = Just (haFilePath h_)
175 augmentIOError other_exception _ _ _
176 = other_exception
177
178 -- ---------------------------------------------------------------------------
179 -- Wrapper for write operations.
180
181 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
182 wantWritableHandle fun h@(FileHandle m) act
183 = wantWritableHandle' fun h m act
184 wantWritableHandle fun h@(DuplexHandle _ m) act
185 = wantWritableHandle' fun h m act
186 -- ToDo: in the Duplex case, we don't need to checkWritableHandle
187
188 wantWritableHandle'
189 :: String -> Handle -> MVar Handle__
190 -> (Handle__ -> IO a) -> IO a
191 wantWritableHandle' fun h m act
192 = withHandle_' fun h m (checkWritableHandle act)
193
194 checkWritableHandle act handle_
195 = case haType handle_ of
196 ClosedHandle -> ioe_closedHandle
197 SemiClosedHandle -> ioe_closedHandle
198 ReadHandle -> ioe_notWritable
199 ReadWriteHandle -> do
200 let ref = haBuffer handle_
201 buf <- readIORef ref
202 new_buf <-
203 if not (bufferIsWritable buf)
204 then do b <- flushReadBuffer (haFD handle_) buf
205 return b{ bufState=WriteBuffer }
206 else return buf
207 writeIORef ref new_buf
208 act handle_
209 _other -> act handle_
210
211 -- ---------------------------------------------------------------------------
212 -- Wrapper for read operations.
213
214 wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
215 wantReadableHandle fun h@(FileHandle m) act
216 = wantReadableHandle' fun h m act
217 wantReadableHandle fun h@(DuplexHandle m _) act
218 = wantReadableHandle' fun h m act
219 -- ToDo: in the Duplex case, we don't need to checkReadableHandle
220
221 wantReadableHandle'
222 :: String -> Handle -> MVar Handle__
223 -> (Handle__ -> IO a) -> IO a
224 wantReadableHandle' fun h m act
225 = withHandle_' fun h m (checkReadableHandle act)
226
227 checkReadableHandle act handle_ =
228 case haType handle_ of
229 ClosedHandle -> ioe_closedHandle
230 SemiClosedHandle -> ioe_closedHandle
231 AppendHandle -> ioe_notReadable
232 WriteHandle -> ioe_notReadable
233 ReadWriteHandle -> do
234 let ref = haBuffer handle_
235 buf <- readIORef ref
236 when (bufferIsWritable buf) $ do
237 new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
238 writeIORef ref new_buf{ bufState=ReadBuffer }
239 act handle_
240 _other -> act handle_
241
242 -- ---------------------------------------------------------------------------
243 -- Wrapper for seek operations.
244
245 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
246 wantSeekableHandle fun h@(DuplexHandle _ _) _act =
247 ioException (IOError (Just h) IllegalOperation fun
248 "handle is not seekable" Nothing)
249 wantSeekableHandle fun h@(FileHandle m) act =
250 withHandle_' fun h m (checkSeekableHandle act)
251
252 checkSeekableHandle act handle_ =
253 case haType handle_ of
254 ClosedHandle -> ioe_closedHandle
255 SemiClosedHandle -> ioe_closedHandle
256 AppendHandle -> ioe_notSeekable
257 _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_
258 | otherwise -> ioe_notSeekable_notBin
259
260 -- -----------------------------------------------------------------------------
261 -- Handy IOErrors
262
263 ioe_closedHandle, ioe_EOF,
264 ioe_notReadable, ioe_notWritable,
265 ioe_notSeekable, ioe_notSeekable_notBin :: IO a
266
267 ioe_closedHandle = ioException
268 (IOError Nothing IllegalOperation ""
269 "handle is closed" Nothing)
270 ioe_EOF = ioException
271 (IOError Nothing EOF "" "" Nothing)
272 ioe_notReadable = ioException
273 (IOError Nothing IllegalOperation ""
274 "handle is not open for reading" Nothing)
275 ioe_notWritable = ioException
276 (IOError Nothing IllegalOperation ""
277 "handle is not open for writing" Nothing)
278 ioe_notSeekable = ioException
279 (IOError Nothing IllegalOperation ""
280 "handle is not seekable" Nothing)
281 ioe_notSeekable_notBin = ioException
282 (IOError Nothing IllegalOperation ""
283 "seek operations on text-mode handles are not allowed on this platform"
284 Nothing)
285
286 ioe_bufsiz :: Int -> IO a
287 ioe_bufsiz n = ioException
288 (IOError Nothing InvalidArgument "hSetBuffering"
289 ("illegal buffer size " ++ showsPrec 9 n []) Nothing)
290 -- 9 => should be parens'ified.
291
292 -- -----------------------------------------------------------------------------
293 -- Handle Finalizers
294
295 -- For a duplex handle, we arrange that the read side points to the write side
296 -- (and hence keeps it alive if the read side is alive). This is done by
297 -- having the haOtherSide field of the read side point to the read side.
298 -- The finalizer is then placed on the write side, and the handle only gets
299 -- finalized once, when both sides are no longer required.
300
301 stdHandleFinalizer :: MVar Handle__ -> IO ()
302 stdHandleFinalizer m = do
303 h_ <- takeMVar m
304 flushWriteBufferOnly h_
305
306 handleFinalizer :: MVar Handle__ -> IO ()
307 handleFinalizer m = do
308 h_ <- takeMVar m
309 flushWriteBufferOnly h_
310 let fd = fromIntegral (haFD h_)
311 unlockFile fd
312 when (fd /= -1)
313 #ifdef mingw32_TARGET_OS
314 (closeFd (haIsStream h_) fd >> return ())
315 #else
316 (c_close fd >> return ())
317 #endif
318 return ()
319
320 -- ---------------------------------------------------------------------------
321 -- Grimy buffer operations
322
323 #ifdef DEBUG
324 checkBufferInvariants h_ = do
325 let ref = haBuffer h_
326 Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref
327 if not (
328 size > 0
329 && r <= w
330 && w <= size
331 && ( r /= w || (r == 0 && w == 0) )
332 && ( state /= WriteBuffer || r == 0 )
333 && ( state /= WriteBuffer || w < size ) -- write buffer is never full
334 )
335 then error "buffer invariant violation"
336 else return ()
337 #else
338 checkBufferInvariants h_ = return ()
339 #endif
340
341 newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer
342 newEmptyBuffer b state size
343 = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state }
344
345 allocateBuffer :: Int -> BufferState -> IO Buffer
346 allocateBuffer sz@(I# size) state = IO $ \s ->
347 case newByteArray# size s of { (# s, b #) ->
348 (# s, newEmptyBuffer b state sz #) }
349
350 writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
351 writeCharIntoBuffer slab (I# off) (C# c)
352 = IO $ \s -> case writeCharArray# slab off c s of
353 s -> (# s, I# (off +# 1#) #)
354
355 readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int)
356 readCharFromBuffer slab (I# off)
357 = IO $ \s -> case readCharArray# slab off s of
358 (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #)
359
360 getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode)
361 getBuffer fd state = do
362 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state
363 ioref <- newIORef buffer
364 is_tty <- fdIsTTY fd
365
366 let buffer_mode
367 | is_tty = LineBuffering
368 | otherwise = BlockBuffering Nothing
369
370 return (ioref, buffer_mode)
371
372 mkUnBuffer :: IO (IORef Buffer)
373 mkUnBuffer = do
374 buffer <- allocateBuffer 1 ReadBuffer
375 newIORef buffer
376
377 -- flushWriteBufferOnly flushes the buffer iff it contains pending write data.
378 flushWriteBufferOnly :: Handle__ -> IO ()
379 flushWriteBufferOnly h_ = do
380 let fd = haFD h_
381 ref = haBuffer h_
382 buf <- readIORef ref
383 new_buf <- if bufferIsWritable buf
384 then flushWriteBuffer fd (haIsStream h_) buf
385 else return buf
386 writeIORef ref new_buf
387
388 -- flushBuffer syncs the file with the buffer, including moving the
389 -- file pointer backwards in the case of a read buffer.
390 flushBuffer :: Handle__ -> IO ()
391 flushBuffer h_ = do
392 let ref = haBuffer h_
393 buf <- readIORef ref
394
395 flushed_buf <-
396 case bufState buf of
397 ReadBuffer -> flushReadBuffer (haFD h_) buf
398 WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf
399
400 writeIORef ref flushed_buf
401
402 -- When flushing a read buffer, we seek backwards by the number of
403 -- characters in the buffer. The file descriptor must therefore be
404 -- seekable: attempting to flush the read buffer on an unseekable
405 -- handle is not allowed.
406
407 flushReadBuffer :: FD -> Buffer -> IO Buffer
408 flushReadBuffer fd buf
409 | bufferEmpty buf = return buf
410 | otherwise = do
411 let off = negate (bufWPtr buf - bufRPtr buf)
412 # ifdef DEBUG_DUMP
413 puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
414 # endif
415 throwErrnoIfMinus1Retry "flushReadBuffer"
416 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
417 return buf{ bufWPtr=0, bufRPtr=0 }
418
419 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
420 flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
421 let bytes = w - r
422 #ifdef DEBUG_DUMP
423 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
424 #endif
425 if bytes == 0
426 then return (buf{ bufRPtr=0, bufWPtr=0 })
427 else do
428 res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
429 (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
430 (fromIntegral bytes))
431 (threadWaitWrite fd)
432 let res' = fromIntegral res
433 if res' < bytes
434 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
435 else return buf{ bufRPtr=0, bufWPtr=0 }
436
437 foreign import ccall unsafe "__hscore_PrelHandle_write"
438 write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
439
440 foreign import ccall unsafe "__hscore_PrelHandle_write"
441 write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
442
443 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
444 fillReadBuffer fd is_line is_stream
445 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
446 -- buffer better be empty:
447 assert (r == 0 && w == 0) $ do
448 fillReadBufferLoop fd is_line is_stream buf b w size
449
450 -- For a line buffer, we just get the first chunk of data to arrive,
451 -- and don't wait for the whole buffer to be full (but we *do* wait
452 -- until some data arrives). This isn't really line buffering, but it
453 -- appears to be what GHC has done for a long time, and I suspect it
454 -- is more useful than line buffering in most cases.
455
456 fillReadBufferLoop fd is_line is_stream buf b w size = do
457 let bytes = size - w
458 if bytes == 0 -- buffer full?
459 then return buf{ bufRPtr=0, bufWPtr=w }
460 else do
461 #ifdef DEBUG_DUMP
462 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
463 #endif
464 res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
465 (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
466 (threadWaitRead fd)
467 let res' = fromIntegral res
468 #ifdef DEBUG_DUMP
469 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
470 #endif
471 if res' == 0
472 then if w == 0
473 then ioe_EOF
474 else return buf{ bufRPtr=0, bufWPtr=w }
475 else if res' < bytes && not is_line
476 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
477 else return buf{ bufRPtr=0, bufWPtr=w+res' }
478
479 foreign import ccall unsafe "__hscore_PrelHandle_read"
480 read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
481
482 foreign import ccall unsafe "__hscore_PrelHandle_read"
483 read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
484
485 -- ---------------------------------------------------------------------------
486 -- Standard Handles
487
488 -- Three handles are allocated during program initialisation. The first
489 -- two manage input or output from the Haskell program's standard input
490 -- or output channel respectively. The third manages output to the
491 -- standard error channel. These handles are initially open.
492
493 fd_stdin = 0 :: FD
494 fd_stdout = 1 :: FD
495 fd_stderr = 2 :: FD
496
497 stdin :: Handle
498 stdin = unsafePerformIO $ do
499 -- ToDo: acquire lock
500 setNonBlockingFD fd_stdin
501 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
502 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
503
504 stdout :: Handle
505 stdout = unsafePerformIO $ do
506 -- ToDo: acquire lock
507 -- We don't set non-blocking mode on stdout or sterr, because
508 -- some shells don't recover properly.
509 -- setNonBlockingFD fd_stdout
510 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
511 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
512
513 stderr :: Handle
514 stderr = unsafePerformIO $ do
515 -- ToDo: acquire lock
516 -- We don't set non-blocking mode on stdout or sterr, because
517 -- some shells don't recover properly.
518 -- setNonBlockingFD fd_stderr
519 buf <- mkUnBuffer
520 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
521
522 -- ---------------------------------------------------------------------------
523 -- Opening and Closing Files
524
525 {-
526 Computation `openFile file mode' allocates and returns a new, open
527 handle to manage the file `file'. It manages input if `mode'
528 is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
529 and both input and output if mode is `ReadWriteMode'.
530
531 If the file does not exist and it is opened for output, it should be
532 created as a new file. If `mode' is `WriteMode' and the file
533 already exists, then it should be truncated to zero length. The
534 handle is positioned at the end of the file if `mode' is
535 `AppendMode', and otherwise at the beginning (in which case its
536 internal position is 0).
537
538 Implementations should enforce, locally to the Haskell process,
539 multiple-reader single-writer locking on files, which is to say that
540 there may either be many handles on the same file which manage input,
541 or just one handle on the file which manages output. If any open or
542 semi-closed handle is managing a file for output, no new handle can be
543 allocated for that file. If any open or semi-closed handle is
544 managing a file for input, new handles can only be allocated if they
545 do not manage output.
546
547 Two files are the same if they have the same absolute name. An
548 implementation is free to impose stricter conditions.
549 -}
550
551 data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
552 deriving (Eq, Ord, Ix, Enum, Read, Show)
553
554 data IOModeEx
555 = BinaryMode IOMode
556 | TextMode IOMode
557 deriving (Eq, Read, Show)
558
559 addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
560 = IOException (IOError h iot fun str (Just fp))
561 addFilePathToIOError _ _ other_exception
562 = other_exception
563
564 openFile :: FilePath -> IOMode -> IO Handle
565 openFile fp im =
566 catch
567 (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
568 then BinaryMode im
569 else TextMode im))
570 (\e -> throw (addFilePathToIOError "openFile" fp e))
571
572 openFileEx :: FilePath -> IOModeEx -> IO Handle
573 openFileEx fp m =
574 catch
575 (openFile' fp m)
576 (\e -> throw (addFilePathToIOError "openFileEx" fp e))
577
578
579 openFile' filepath ex_mode =
580 withCString filepath $ \ f ->
581
582 let
583 (mode, binary) =
584 case ex_mode of
585 BinaryMode bmo -> (bmo, True)
586 TextMode tmo -> (tmo, False)
587
588 oflags1 = case mode of
589 ReadMode -> read_flags
590 WriteMode -> write_flags
591 ReadWriteMode -> rw_flags
592 AppendMode -> append_flags
593
594 truncate | WriteMode <- mode = True
595 | otherwise = False
596
597 binary_flags
598 | binary = o_BINARY
599 | otherwise = 0
600
601 oflags = oflags1 .|. binary_flags
602 in do
603
604 -- the old implementation had a complicated series of three opens,
605 -- which is perhaps because we have to be careful not to open
606 -- directories. However, the man pages I've read say that open()
607 -- always returns EISDIR if the file is a directory and was opened
608 -- for writing, so I think we're ok with a single open() here...
609 fd <- fromIntegral `liftM`
610 throwErrnoIfMinus1Retry "openFile"
611 (c_open f (fromIntegral oflags) 0o666)
612
613 openFd fd Nothing filepath mode binary truncate
614 -- ASSERT: if we just created the file, then openFd won't fail
615 -- (so we don't need to worry about removing the newly created file
616 -- in the event of an error).
617
618
619 std_flags = o_NONBLOCK .|. o_NOCTTY
620 output_flags = std_flags .|. o_CREAT
621 read_flags = std_flags .|. o_RDONLY
622 write_flags = output_flags .|. o_WRONLY
623 rw_flags = output_flags .|. o_RDWR
624 append_flags = write_flags .|. o_APPEND
625
626 -- ---------------------------------------------------------------------------
627 -- openFd
628
629 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
630 openFd fd mb_fd_type filepath mode binary truncate = do
631 -- turn on non-blocking mode
632 setNonBlockingFD fd
633
634 let (ha_type, write) =
635 case mode of
636 ReadMode -> ( ReadHandle, False )
637 WriteMode -> ( WriteHandle, True )
638 ReadWriteMode -> ( ReadWriteHandle, True )
639 AppendMode -> ( AppendHandle, True )
640
641 -- open() won't tell us if it was a directory if we only opened for
642 -- reading, so check again.
643 fd_type <-
644 case mb_fd_type of
645 Just x -> return x
646 Nothing -> fdType fd
647 let is_stream = fd_type == Stream
648 case fd_type of
649 Directory ->
650 ioException (IOError Nothing InappropriateType "openFile"
651 "is a directory" Nothing)
652
653 Stream
654 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
655 | otherwise -> mkFileHandle fd is_stream filepath ha_type binary
656
657 -- regular files need to be locked
658 RegularFile -> do
659 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
660 when (r == -1) $
661 ioException (IOError Nothing ResourceBusy "openFile"
662 "file is locked" Nothing)
663
664 -- truncate the file if necessary
665 when truncate (fileTruncate filepath)
666
667 mkFileHandle fd is_stream filepath ha_type binary
668
669
670 foreign import ccall unsafe "lockFile"
671 lockFile :: CInt -> CInt -> CInt -> IO CInt
672
673 foreign import ccall unsafe "unlockFile"
674 unlockFile :: CInt -> IO CInt
675
676 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
677 -> IO Handle
678 mkStdHandle fd filepath ha_type buf bmode = do
679 spares <- newIORef BufferListNil
680 newFileHandle stdHandleFinalizer
681 (Handle__ { haFD = fd,
682 haType = ha_type,
683 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
684 haIsStream = False,
685 haBufferMode = bmode,
686 haFilePath = filepath,
687 haBuffer = buf,
688 haBuffers = spares,
689 haOtherSide = Nothing
690 })
691
692 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
693 mkFileHandle fd is_stream filepath ha_type binary = do
694 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
695 spares <- newIORef BufferListNil
696 newFileHandle handleFinalizer
697 (Handle__ { haFD = fd,
698 haType = ha_type,
699 haIsBin = binary,
700 haIsStream = is_stream,
701 haBufferMode = bmode,
702 haFilePath = filepath,
703 haBuffer = buf,
704 haBuffers = spares,
705 haOtherSide = Nothing
706 })
707
708 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
709 mkDuplexHandle fd is_stream filepath binary = do
710 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
711 w_spares <- newIORef BufferListNil
712 let w_handle_ =
713 Handle__ { haFD = fd,
714 haType = WriteHandle,
715 haIsBin = binary,
716 haIsStream = is_stream,
717 haBufferMode = w_bmode,
718 haFilePath = filepath,
719 haBuffer = w_buf,
720 haBuffers = w_spares,
721 haOtherSide = Nothing
722 }
723 write_side <- newMVar w_handle_
724
725 (r_buf, r_bmode) <- getBuffer fd ReadBuffer
726 r_spares <- newIORef BufferListNil
727 let r_handle_ =
728 Handle__ { haFD = fd,
729 haType = ReadHandle,
730 haIsBin = binary,
731 haIsStream = is_stream,
732 haBufferMode = r_bmode,
733 haFilePath = filepath,
734 haBuffer = r_buf,
735 haBuffers = r_spares,
736 haOtherSide = Just write_side
737 }
738 read_side <- newMVar r_handle_
739
740 addMVarFinalizer read_side (handleFinalizer read_side)
741 return (DuplexHandle read_side write_side)
742
743
744 initBufferState ReadHandle = ReadBuffer
745 initBufferState _ = WriteBuffer
746
747 -- ---------------------------------------------------------------------------
748 -- Closing a handle
749
750 -- Computation `hClose hdl' makes handle `hdl' closed. Before the
751 -- computation finishes, any items buffered for output and not already
752 -- sent to the operating system are flushed as for `hFlush'.
753
754 -- For a duplex handle, we close&flush the write side, and just close
755 -- the read side.
756
757 hClose :: Handle -> IO ()
758 hClose h@(FileHandle m) = hClose' h m
759 hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
760
761 hClose' h m = withHandle__' "hClose" h m $ hClose_help
762
763 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
764 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
765 -- then closed immediately. We have to be careful with DuplexHandles
766 -- though: we have to leave the closing to the finalizer in that case,
767 -- because the write side may still be in use.
768 hClose_help :: Handle__ -> IO Handle__
769 hClose_help handle_ =
770 case haType handle_ of
771 ClosedHandle -> return handle_
772 _ -> do
773 let fd = haFD handle_
774 c_fd = fromIntegral fd
775
776 flushWriteBufferOnly handle_
777
778 -- close the file descriptor, but not when this is the read
779 -- side of a duplex handle, and not when this is one of the
780 -- std file handles.
781 case haOtherSide handle_ of
782 Nothing ->
783 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
784 throwErrnoIfMinus1Retry_ "hClose"
785 #ifdef mingw32_TARGET_OS
786 (closeFd (haIsStream handle_) c_fd)
787 #else
788 (c_close c_fd)
789 #endif
790 Just _ -> return ()
791
792 -- free the spare buffers
793 writeIORef (haBuffers handle_) BufferListNil
794
795 -- unlock it
796 unlockFile c_fd
797
798 -- we must set the fd to -1, because the finalizer is going
799 -- to run eventually and try to close/unlock it.
800 return (handle_{ haFD = -1,
801 haType = ClosedHandle
802 })
803
804 -----------------------------------------------------------------------------
805 -- Detecting the size of a file
806
807 -- For a handle `hdl' which attached to a physical file, `hFileSize
808 -- hdl' returns the size of `hdl' in terms of the number of items
809 -- which can be read from `hdl'.
810
811 hFileSize :: Handle -> IO Integer
812 hFileSize handle =
813 withHandle_ "hFileSize" handle $ \ handle_ -> do
814 case haType handle_ of
815 ClosedHandle -> ioe_closedHandle
816 SemiClosedHandle -> ioe_closedHandle
817 _ -> do flushWriteBufferOnly handle_
818 r <- fdFileSize (haFD handle_)
819 if r /= -1
820 then return r
821 else ioException (IOError Nothing InappropriateType "hFileSize"
822 "not a regular file" Nothing)
823
824 -- ---------------------------------------------------------------------------
825 -- Detecting the End of Input
826
827 -- For a readable handle `hdl', `hIsEOF hdl' returns
828 -- `True' if no further input can be taken from `hdl' or for a
829 -- physical file, if the current I/O position is equal to the length of
830 -- the file. Otherwise, it returns `False'.
831
832 hIsEOF :: Handle -> IO Bool
833 hIsEOF handle =
834 catch
835 (do hLookAhead handle; return False)
836 (\e -> if isEOFError e then return True else throw e)
837
838 isEOF :: IO Bool
839 isEOF = hIsEOF stdin
840
841 -- ---------------------------------------------------------------------------
842 -- Looking ahead
843
844 -- hLookahead returns the next character from the handle without
845 -- removing it from the input buffer, blocking until a character is
846 -- available.
847
848 hLookAhead :: Handle -> IO Char
849 hLookAhead handle = do
850 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
851 let ref = haBuffer handle_
852 fd = haFD handle_
853 is_line = haBufferMode handle_ == LineBuffering
854 buf <- readIORef ref
855
856 -- fill up the read buffer if necessary
857 new_buf <- if bufferEmpty buf
858 then fillReadBuffer fd is_line (haIsStream handle_) buf
859 else return buf
860
861 writeIORef ref new_buf
862
863 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
864 return c
865
866 -- ---------------------------------------------------------------------------
867 -- Buffering Operations
868
869 -- Three kinds of buffering are supported: line-buffering,
870 -- block-buffering or no-buffering. See GHC.IOBase for definition and
871 -- further explanation of what the type represent.
872
873 -- Computation `hSetBuffering hdl mode' sets the mode of buffering for
874 -- handle hdl on subsequent reads and writes.
875 --
876 -- * If mode is LineBuffering, line-buffering should be enabled if possible.
877 --
878 -- * If mode is `BlockBuffering size', then block-buffering
879 -- should be enabled if possible. The size of the buffer is n items
880 -- if size is `Just n' and is otherwise implementation-dependent.
881 --
882 -- * If mode is NoBuffering, then buffering is disabled if possible.
883
884 -- If the buffer mode is changed from BlockBuffering or
885 -- LineBuffering to NoBuffering, then any items in the output
886 -- buffer are written to the device, and any items in the input buffer
887 -- are discarded. The default buffering mode when a handle is opened
888 -- is implementation-dependent and may depend on the object which is
889 -- attached to that handle.
890
891 hSetBuffering :: Handle -> BufferMode -> IO ()
892 hSetBuffering handle mode =
893 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
894 case haType handle_ of
895 ClosedHandle -> ioe_closedHandle
896 _ -> do
897 {- Note:
898 - we flush the old buffer regardless of whether
899 the new buffer could fit the contents of the old buffer
900 or not.
901 - allow a handle's buffering to change even if IO has
902 occurred (ANSI C spec. does not allow this, nor did
903 the previous implementation of IO.hSetBuffering).
904 - a non-standard extension is to allow the buffering
905 of semi-closed handles to change [sof 6/98]
906 -}
907 flushBuffer handle_
908
909 let state = initBufferState (haType handle_)
910 new_buf <-
911 case mode of
912 -- we always have a 1-character read buffer for
913 -- unbuffered handles: it's needed to
914 -- support hLookAhead.
915 NoBuffering -> allocateBuffer 1 ReadBuffer
916 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
917 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
918 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
919 | otherwise -> allocateBuffer n state
920 writeIORef (haBuffer handle_) new_buf
921
922 -- for input terminals we need to put the terminal into
923 -- cooked or raw mode depending on the type of buffering.
924 is_tty <- fdIsTTY (haFD handle_)
925 when (is_tty && isReadableHandleType (haType handle_)) $
926 case mode of
927 NoBuffering -> setCooked (haFD handle_) False
928 _ -> setCooked (haFD handle_) True
929
930 -- throw away spare buffers, they might be the wrong size
931 writeIORef (haBuffers handle_) BufferListNil
932
933 return (handle_{ haBufferMode = mode })
934
935 -- -----------------------------------------------------------------------------
936 -- hFlush
937
938 -- The action `hFlush hdl' causes any items buffered for output
939 -- in handle `hdl' to be sent immediately to the operating
940 -- system.
941
942 hFlush :: Handle -> IO ()
943 hFlush handle =
944 wantWritableHandle "hFlush" handle $ \ handle_ -> do
945 buf <- readIORef (haBuffer handle_)
946 if bufferIsWritable buf && not (bufferEmpty buf)
947 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
948 writeIORef (haBuffer handle_) flushed_buf
949 else return ()
950
951
952 -- -----------------------------------------------------------------------------
953 -- Repositioning Handles
954
955 data HandlePosn = HandlePosn Handle HandlePosition
956
957 instance Eq HandlePosn where
958 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
959
960 instance Show HandlePosn where
961 showsPrec p (HandlePosn h pos) =
962 showsPrec p h . showString " at position " . shows pos
963
964 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
965 -- We represent it as an Integer on the Haskell side, but
966 -- cheat slightly in that hGetPosn calls upon a C helper
967 -- that reports the position back via (merely) an Int.
968 type HandlePosition = Integer
969
970 -- Computation `hGetPosn hdl' returns the current I/O position of
971 -- `hdl' as an abstract position. Computation `hSetPosn p' sets the
972 -- position of `hdl' to a previously obtained position `p'.
973
974 hGetPosn :: Handle -> IO HandlePosn
975 hGetPosn handle = do
976 posn <- hTell handle
977 return (HandlePosn handle posn)
978
979 hSetPosn :: HandlePosn -> IO ()
980 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
981
982 -- ---------------------------------------------------------------------------
983 -- hSeek
984
985 {-
986 The action `hSeek hdl mode i' sets the position of handle
987 `hdl' depending on `mode'. If `mode' is
988
989 * AbsoluteSeek - The position of `hdl' is set to `i'.
990 * RelativeSeek - The position of `hdl' is set to offset `i' from
991 the current position.
992 * SeekFromEnd - The position of `hdl' is set to offset `i' from
993 the end of the file.
994
995 Some handles may not be seekable (see `hIsSeekable'), or only
996 support a subset of the possible positioning operations (e.g. it may
997 only be possible to seek to the end of a tape, or to a positive
998 offset from the beginning or current position).
999
1000 It is not possible to set a negative I/O position, or for a physical
1001 file, an I/O position beyond the current end-of-file.
1002
1003 Note:
1004 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1005 seeking at or past EOF.
1006
1007 - we possibly deviate from the report on the issue of seeking within
1008 the buffer and whether to flush it or not. The report isn't exactly
1009 clear here.
1010 -}
1011
1012 data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
1013 deriving (Eq, Ord, Ix, Enum, Read, Show)
1014
1015 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1016 hSeek handle mode offset =
1017 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1018 # ifdef DEBUG_DUMP
1019 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1020 # endif
1021 let ref = haBuffer handle_
1022 buf <- readIORef ref
1023 let r = bufRPtr buf
1024 w = bufWPtr buf
1025 fd = haFD handle_
1026
1027 let do_seek =
1028 throwErrnoIfMinus1Retry_ "hSeek"
1029 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1030
1031 whence :: CInt
1032 whence = case mode of
1033 AbsoluteSeek -> sEEK_SET
1034 RelativeSeek -> sEEK_CUR
1035 SeekFromEnd -> sEEK_END
1036
1037 if bufferIsWritable buf
1038 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1039 writeIORef ref new_buf
1040 do_seek
1041 else do
1042
1043 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1044 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1045 else do
1046
1047 new_buf <- flushReadBuffer (haFD handle_) buf
1048 writeIORef ref new_buf
1049 do_seek
1050
1051
1052 hTell :: Handle -> IO Integer
1053 hTell handle =
1054 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1055
1056 #if defined(mingw32_TARGET_OS)
1057 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1058 -- so we can't easily calculate the file position using the
1059 -- current buffer size. Just flush instead.
1060 flushBuffer handle_
1061 #endif
1062 let fd = fromIntegral (haFD handle_)
1063 posn <- fromIntegral `liftM`
1064 throwErrnoIfMinus1Retry "hGetPosn"
1065 (c_lseek fd 0 sEEK_CUR)
1066
1067 let ref = haBuffer handle_
1068 buf <- readIORef ref
1069
1070 let real_posn
1071 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1072 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1073 # ifdef DEBUG_DUMP
1074 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1075 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1076 # endif
1077 return real_posn
1078
1079 -- -----------------------------------------------------------------------------
1080 -- Handle Properties
1081
1082 -- A number of operations return information about the properties of a
1083 -- handle. Each of these operations returns `True' if the handle has
1084 -- the specified property, and `False' otherwise.
1085
1086 hIsOpen :: Handle -> IO Bool
1087 hIsOpen handle =
1088 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1089 case haType handle_ of
1090 ClosedHandle -> return False
1091 SemiClosedHandle -> return False
1092 _ -> return True
1093
1094 hIsClosed :: Handle -> IO Bool
1095 hIsClosed handle =
1096 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1097 case haType handle_ of
1098 ClosedHandle -> return True
1099 _ -> return False
1100
1101 {- not defined, nor exported, but mentioned
1102 here for documentation purposes:
1103
1104 hSemiClosed :: Handle -> IO Bool
1105 hSemiClosed h = do
1106 ho <- hIsOpen h
1107 hc <- hIsClosed h
1108 return (not (ho || hc))
1109 -}
1110
1111 hIsReadable :: Handle -> IO Bool
1112 hIsReadable (DuplexHandle _ _) = return True
1113 hIsReadable handle =
1114 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1115 case haType handle_ of
1116 ClosedHandle -> ioe_closedHandle
1117 SemiClosedHandle -> ioe_closedHandle
1118 htype -> return (isReadableHandleType htype)
1119
1120 hIsWritable :: Handle -> IO Bool
1121 hIsWritable (DuplexHandle _ _) = return False
1122 hIsWritable handle =
1123 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1124 case haType handle_ of
1125 ClosedHandle -> ioe_closedHandle
1126 SemiClosedHandle -> ioe_closedHandle
1127 htype -> return (isWritableHandleType htype)
1128
1129 -- Querying how a handle buffers its data:
1130
1131 hGetBuffering :: Handle -> IO BufferMode
1132 hGetBuffering handle =
1133 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1134 case haType handle_ of
1135 ClosedHandle -> ioe_closedHandle
1136 _ ->
1137 -- We're being non-standard here, and allow the buffering
1138 -- of a semi-closed handle to be queried. -- sof 6/98
1139 return (haBufferMode handle_) -- could be stricter..
1140
1141 hIsSeekable :: Handle -> IO Bool
1142 hIsSeekable handle =
1143 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1144 case haType handle_ of
1145 ClosedHandle -> ioe_closedHandle
1146 SemiClosedHandle -> ioe_closedHandle
1147 AppendHandle -> return False
1148 _ -> do t <- fdType (haFD handle_)
1149 return (t == RegularFile
1150 && (haIsBin handle_
1151 || tEXT_MODE_SEEK_ALLOWED))
1152
1153 -- -----------------------------------------------------------------------------
1154 -- Changing echo status
1155
1156 -- Non-standard GHC extension is to allow the echoing status
1157 -- of a handles connected to terminals to be reconfigured:
1158
1159 hSetEcho :: Handle -> Bool -> IO ()
1160 hSetEcho handle on = do
1161 isT <- hIsTerminalDevice handle
1162 if not isT
1163 then return ()
1164 else
1165 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1166 case haType handle_ of
1167 ClosedHandle -> ioe_closedHandle
1168 _ -> setEcho (haFD handle_) on
1169
1170 hGetEcho :: Handle -> IO Bool
1171 hGetEcho handle = do
1172 isT <- hIsTerminalDevice handle
1173 if not isT
1174 then return False
1175 else
1176 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1177 case haType handle_ of
1178 ClosedHandle -> ioe_closedHandle
1179 _ -> getEcho (haFD handle_)
1180
1181 hIsTerminalDevice :: Handle -> IO Bool
1182 hIsTerminalDevice handle = do
1183 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1184 case haType handle_ of
1185 ClosedHandle -> ioe_closedHandle
1186 _ -> fdIsTTY (haFD handle_)
1187
1188 -- -----------------------------------------------------------------------------
1189 -- hSetBinaryMode
1190
1191 -- | On Windows, reading a file in text mode (which is the default) will
1192 -- translate CRLF to LF, and writing will translate LF to CRLF. This
1193 -- is usually what you want with text files. With binary files this is
1194 -- undesirable; also, as usual under Microsoft operating systems, text
1195 -- mode treats control-Z as EOF. Setting binary mode using
1196 -- 'hSetBinaryMode' turns off all special treatment of end-of-line and
1197 -- end-of-file characters.
1198 --
1199 hSetBinaryMode :: Handle -> Bool -> IO ()
1200 hSetBinaryMode handle bin =
1201 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1202 do throwErrnoIfMinus1_ "hSetBinaryMode"
1203 (setmode (fromIntegral (haFD handle_)) bin)
1204 return handle_{haIsBin=bin}
1205
1206 foreign import ccall unsafe "__hscore_setmode"
1207 setmode :: CInt -> Bool -> IO CInt
1208
1209 -- ---------------------------------------------------------------------------
1210 -- debugging
1211
1212 #ifdef DEBUG_DUMP
1213 puts :: String -> IO ()
1214 puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
1215 return ()
1216 #endif
1217
1218 -- -----------------------------------------------------------------------------
1219 -- wrappers to platform-specific constants:
1220
1221 foreign import ccall unsafe "__hscore_supportsTextMode"
1222 tEXT_MODE_SEEK_ALLOWED :: Bool
1223
1224 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1225 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1226 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1227 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt