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