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