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