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