[project @ 2003-09-23 13:23:58 by simonmar]
[ghc.git] / libraries / base / GHC / Handle.hs
1 {-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
2
3 #undef DEBUG_DUMP
4 #undef DEBUG
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : GHC.Handle
9 -- Copyright : (c) The University of Glasgow, 1994-2001
10 -- License : see libraries/base/LICENSE
11 --
12 -- Maintainer : libraries@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable
15 --
16 -- This module defines the basic operations on I\/O \"handles\".
17 --
18 -----------------------------------------------------------------------------
19
20 module GHC.Handle (
21 withHandle, withHandle', withHandle_,
22 wantWritableHandle, wantReadableHandle, wantSeekableHandle,
23
24 newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
25 flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
26 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 HandlePosition, 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 } =
445 seq fd $ do -- strictness hack
446 let bytes = w - r
447 #ifdef DEBUG_DUMP
448 puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
449 #endif
450 if bytes == 0
451 then return (buf{ bufRPtr=0, bufWPtr=0 })
452 else do
453 res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
454 (fromIntegral r) (fromIntegral bytes)
455 let res' = fromIntegral res
456 if res' < bytes
457 then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
458 else return buf{ bufRPtr=0, bufWPtr=0 }
459
460 fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
461 fillReadBuffer fd is_line is_stream
462 buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
463 -- buffer better be empty:
464 assert (r == 0 && w == 0) $ do
465 fillReadBufferLoop fd is_line is_stream buf b w size
466
467 -- For a line buffer, we just get the first chunk of data to arrive,
468 -- and don't wait for the whole buffer to be full (but we *do* wait
469 -- until some data arrives). This isn't really line buffering, but it
470 -- appears to be what GHC has done for a long time, and I suspect it
471 -- is more useful than line buffering in most cases.
472
473 fillReadBufferLoop fd is_line is_stream buf b w size = do
474 let bytes = size - w
475 if bytes == 0 -- buffer full?
476 then return buf{ bufRPtr=0, bufWPtr=w }
477 else do
478 #ifdef DEBUG_DUMP
479 puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
480 #endif
481 res <- readRawBuffer "fillReadBuffer" fd is_stream b
482 (fromIntegral w) (fromIntegral bytes)
483 let res' = fromIntegral res
484 #ifdef DEBUG_DUMP
485 puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
486 #endif
487 if res' == 0
488 then if w == 0
489 then ioe_EOF
490 else return buf{ bufRPtr=0, bufWPtr=w }
491 else if res' < bytes && not is_line
492 then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
493 else return buf{ bufRPtr=0, bufWPtr=w+res' }
494
495
496 -- Low level routines for reading/writing to (raw)buffers:
497
498 #ifndef mingw32_TARGET_OS
499 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
500 readRawBuffer loc fd is_stream buf off len =
501 throwErrnoIfMinus1RetryMayBlock loc
502 (read_rawBuffer fd is_stream buf off len)
503 (threadWaitRead fd)
504
505 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
506 readRawBufferPtr loc fd is_stream buf off len =
507 throwErrnoIfMinus1RetryMayBlock loc
508 (read_off fd is_stream buf off len)
509 (threadWaitRead fd)
510
511 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
512 writeRawBuffer loc fd is_stream buf off len =
513 throwErrnoIfMinus1RetryMayBlock loc
514 (write_rawBuffer (fromIntegral fd) is_stream buf off len)
515 (threadWaitWrite fd)
516
517 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
518 writeRawBufferPtr loc fd is_stream buf off len =
519 throwErrnoIfMinus1RetryMayBlock loc
520 (write_off (fromIntegral fd) is_stream buf off len)
521 (threadWaitWrite fd)
522
523 foreign import ccall unsafe "__hscore_PrelHandle_read"
524 read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
525
526 foreign import ccall unsafe "__hscore_PrelHandle_read"
527 read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
528
529 foreign import ccall unsafe "__hscore_PrelHandle_write"
530 write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
531
532 foreign import ccall unsafe "__hscore_PrelHandle_write"
533 write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
534
535 #else
536 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
537 readRawBuffer loc fd is_stream buf off len = do
538 (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
539 if l == (-1)
540 then
541 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
542 else return (fromIntegral l)
543
544 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
545 readRawBufferPtr loc fd is_stream buf off len = do
546 (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
547 if l == (-1)
548 then
549 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
550 else return (fromIntegral l)
551
552 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
553 writeRawBuffer loc fd is_stream buf off len = do
554 (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
555 if l == (-1)
556 then
557 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
558 else return (fromIntegral l)
559
560 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
561 writeRawBufferPtr loc fd is_stream buf off len = do
562 (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
563 if l == (-1)
564 then
565 ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
566 else return (fromIntegral l)
567
568 foreign import ccall unsafe "__hscore_PrelHandle_read"
569 read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
570
571 foreign import ccall unsafe "__hscore_PrelHandle_read"
572 read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
573
574 foreign import ccall unsafe "__hscore_PrelHandle_write"
575 write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
576
577 foreign import ccall unsafe "__hscore_PrelHandle_write"
578 write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
579
580 #endif
581
582 -- ---------------------------------------------------------------------------
583 -- Standard Handles
584
585 -- Three handles are allocated during program initialisation. The first
586 -- two manage input or output from the Haskell program's standard input
587 -- or output channel respectively. The third manages output to the
588 -- standard error channel. These handles are initially open.
589
590 fd_stdin = 0 :: FD
591 fd_stdout = 1 :: FD
592 fd_stderr = 2 :: FD
593
594 -- | A handle managing input from the Haskell program's standard input channel.
595 stdin :: Handle
596 stdin = unsafePerformIO $ do
597 -- ToDo: acquire lock
598 setNonBlockingFD fd_stdin
599 (buf, bmode) <- getBuffer fd_stdin ReadBuffer
600 mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
601
602 -- | A handle managing output to the Haskell program's standard output channel.
603 stdout :: Handle
604 stdout = unsafePerformIO $ do
605 -- ToDo: acquire lock
606 -- We don't set non-blocking mode on stdout or sterr, because
607 -- some shells don't recover properly.
608 -- setNonBlockingFD fd_stdout
609 (buf, bmode) <- getBuffer fd_stdout WriteBuffer
610 mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
611
612 -- | A handle managing output to the Haskell program's standard error channel.
613 stderr :: Handle
614 stderr = unsafePerformIO $ do
615 -- ToDo: acquire lock
616 -- We don't set non-blocking mode on stdout or sterr, because
617 -- some shells don't recover properly.
618 -- setNonBlockingFD fd_stderr
619 buf <- mkUnBuffer
620 mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
621
622 -- ---------------------------------------------------------------------------
623 -- Opening and Closing Files
624
625 addFilePathToIOError fun fp (IOError h iot _ str _)
626 = IOError h iot fun str (Just fp)
627
628 -- | Computation 'openFile' @file mode@ allocates and returns a new, open
629 -- handle to manage the file @file@. It manages input if @mode@
630 -- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
631 -- and both input and output if mode is 'ReadWriteMode'.
632 --
633 -- If the file does not exist and it is opened for output, it should be
634 -- created as a new file. If @mode@ is 'WriteMode' and the file
635 -- already exists, then it should be truncated to zero length.
636 -- Some operating systems delete empty files, so there is no guarantee
637 -- that the file will exist following an 'openFile' with @mode@
638 -- 'WriteMode' unless it is subsequently written to successfully.
639 -- The handle is positioned at the end of the file if @mode@ is
640 -- 'AppendMode', and otherwise at the beginning (in which case its
641 -- internal position is 0).
642 -- The initial buffer mode is implementation-dependent.
643 --
644 -- This operation may fail with:
645 --
646 -- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
647 --
648 -- * 'isDoesNotExistError' if the file does not exist; or
649 --
650 -- * 'isPermissionError' if the user does not have permission to open the file.
651
652 openFile :: FilePath -> IOMode -> IO Handle
653 openFile fp im =
654 catch
655 (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
656 (\e -> ioError (addFilePathToIOError "openFile" fp e))
657
658 -- | Like 'openFile', but open the file in binary mode.
659 -- On Windows, reading a file in text mode (which is the default)
660 -- will translate CRLF to LF, and writing will translate LF to CRLF.
661 -- This is usually what you want with text files. With binary files
662 -- this is undesirable; also, as usual under Microsoft operating systems,
663 -- text mode treats control-Z as EOF. Binary mode turns off all special
664 -- treatment of end-of-line and end-of-file characters.
665 -- (See also 'hSetBinaryMode'.)
666
667 openBinaryFile :: FilePath -> IOMode -> IO Handle
668 openBinaryFile fp m =
669 catch
670 (openFile' fp m True)
671 (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
672
673 openFile' filepath mode binary =
674 withCString filepath $ \ f ->
675
676 let
677 oflags1 = case mode of
678 ReadMode -> read_flags
679 WriteMode -> write_flags
680 ReadWriteMode -> rw_flags
681 AppendMode -> append_flags
682
683 truncate | WriteMode <- mode = True
684 | otherwise = False
685
686 binary_flags
687 | binary = o_BINARY
688 | otherwise = 0
689
690 oflags = oflags1 .|. binary_flags
691 in do
692
693 -- the old implementation had a complicated series of three opens,
694 -- which is perhaps because we have to be careful not to open
695 -- directories. However, the man pages I've read say that open()
696 -- always returns EISDIR if the file is a directory and was opened
697 -- for writing, so I think we're ok with a single open() here...
698 fd <- fromIntegral `liftM`
699 throwErrnoIfMinus1Retry "openFile"
700 (c_open f (fromIntegral oflags) 0o666)
701
702 openFd fd Nothing filepath mode binary truncate
703 -- ASSERT: if we just created the file, then openFd won't fail
704 -- (so we don't need to worry about removing the newly created file
705 -- in the event of an error).
706
707
708 std_flags = o_NONBLOCK .|. o_NOCTTY
709 output_flags = std_flags .|. o_CREAT
710 read_flags = std_flags .|. o_RDONLY
711 write_flags = output_flags .|. o_WRONLY
712 rw_flags = output_flags .|. o_RDWR
713 append_flags = write_flags .|. o_APPEND
714
715 -- ---------------------------------------------------------------------------
716 -- openFd
717
718 openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
719 openFd fd mb_fd_type filepath mode binary truncate = do
720 -- turn on non-blocking mode
721 setNonBlockingFD fd
722
723 let (ha_type, write) =
724 case mode of
725 ReadMode -> ( ReadHandle, False )
726 WriteMode -> ( WriteHandle, True )
727 ReadWriteMode -> ( ReadWriteHandle, True )
728 AppendMode -> ( AppendHandle, True )
729
730 -- open() won't tell us if it was a directory if we only opened for
731 -- reading, so check again.
732 fd_type <-
733 case mb_fd_type of
734 Just x -> return x
735 Nothing -> fdType fd
736 let is_stream = fd_type == Stream
737 case fd_type of
738 Directory ->
739 ioException (IOError Nothing InappropriateType "openFile"
740 "is a directory" Nothing)
741
742 Stream
743 | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
744 | otherwise -> mkFileHandle fd is_stream filepath ha_type binary
745
746 -- regular files need to be locked
747 RegularFile -> do
748 r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
749 when (r == -1) $
750 ioException (IOError Nothing ResourceBusy "openFile"
751 "file is locked" Nothing)
752
753 -- truncate the file if necessary
754 when truncate (fileTruncate filepath)
755
756 mkFileHandle fd is_stream filepath ha_type binary
757
758
759 fdToHandle :: FD -> IO Handle
760 fdToHandle fd = do
761 mode <- fdGetMode fd
762 let fd_str = "<file descriptor: " ++ show fd ++ ">"
763 openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
764
765 foreign import ccall unsafe "lockFile"
766 lockFile :: CInt -> CInt -> CInt -> IO CInt
767
768 foreign import ccall unsafe "unlockFile"
769 unlockFile :: CInt -> IO CInt
770
771 mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
772 -> IO Handle
773 mkStdHandle fd filepath ha_type buf bmode = do
774 spares <- newIORef BufferListNil
775 newFileHandle filepath stdHandleFinalizer
776 (Handle__ { haFD = fd,
777 haType = ha_type,
778 haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
779 haIsStream = False,
780 haBufferMode = bmode,
781 haBuffer = buf,
782 haBuffers = spares,
783 haOtherSide = Nothing
784 })
785
786 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
787 mkFileHandle fd is_stream filepath ha_type binary = do
788 (buf, bmode) <- getBuffer fd (initBufferState ha_type)
789 spares <- newIORef BufferListNil
790 newFileHandle filepath handleFinalizer
791 (Handle__ { haFD = fd,
792 haType = ha_type,
793 haIsBin = binary,
794 haIsStream = is_stream,
795 haBufferMode = bmode,
796 haBuffer = buf,
797 haBuffers = spares,
798 haOtherSide = Nothing
799 })
800
801 mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle
802 mkDuplexHandle fd is_stream filepath binary = do
803 (w_buf, w_bmode) <- getBuffer fd WriteBuffer
804 w_spares <- newIORef BufferListNil
805 let w_handle_ =
806 Handle__ { haFD = fd,
807 haType = WriteHandle,
808 haIsBin = binary,
809 haIsStream = is_stream,
810 haBufferMode = w_bmode,
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 haBuffer = r_buf,
826 haBuffers = r_spares,
827 haOtherSide = Just write_side
828 }
829 read_side <- newMVar r_handle_
830
831 addMVarFinalizer write_side (handleFinalizer write_side)
832 return (DuplexHandle filepath read_side write_side)
833
834
835 initBufferState ReadHandle = ReadBuffer
836 initBufferState _ = WriteBuffer
837
838 -- ---------------------------------------------------------------------------
839 -- Closing a handle
840
841 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
842 -- computation finishes, if @hdl@ is writable its buffer is flushed as
843 -- for 'hFlush'.
844 -- Performing 'hClose' on a handle that has already been closed has no effect;
845 -- doing so not an error. All other operations on a closed handle will fail.
846 -- If 'hClose' fails for any reason, any further operations (apart from
847 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
848 -- closed.
849
850 hClose :: Handle -> IO ()
851 hClose h@(FileHandle _ m) = hClose' h m
852 hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
853
854 hClose' h m = withHandle__' "hClose" h m $ hClose_help
855
856 -- hClose_help is also called by lazyRead (in PrelIO) when EOF is read
857 -- or an IO error occurs on a lazy stream. The semi-closed Handle is
858 -- then closed immediately. We have to be careful with DuplexHandles
859 -- though: we have to leave the closing to the finalizer in that case,
860 -- because the write side may still be in use.
861 hClose_help :: Handle__ -> IO Handle__
862 hClose_help handle_ =
863 case haType handle_ of
864 ClosedHandle -> return handle_
865 _ -> do flushWriteBufferOnly handle_ -- interruptible
866 hClose_handle_ handle_
867
868 hClose_handle_ handle_ = do
869 let fd = haFD handle_
870 c_fd = fromIntegral fd
871
872 -- close the file descriptor, but not when this is the read
873 -- side of a duplex handle, and not when this is one of the
874 -- std file handles.
875 case haOtherSide handle_ of
876 Nothing ->
877 when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
878 throwErrnoIfMinus1Retry_ "hClose"
879 #ifdef mingw32_TARGET_OS
880 (closeFd (haIsStream handle_) c_fd)
881 #else
882 (c_close c_fd)
883 #endif
884 Just _ -> return ()
885
886 -- free the spare buffers
887 writeIORef (haBuffers handle_) BufferListNil
888
889 -- unlock it
890 unlockFile c_fd
891
892 -- we must set the fd to -1, because the finalizer is going
893 -- to run eventually and try to close/unlock it.
894 return (handle_{ haFD = -1,
895 haType = ClosedHandle
896 })
897
898 -----------------------------------------------------------------------------
899 -- Detecting the size of a file
900
901 -- | For a handle @hdl@ which attached to a physical file,
902 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
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 -- | The computation 'isEOF' is identical to 'hIsEOF',
932 -- except that it works only on 'stdin'.
933
934 isEOF :: IO Bool
935 isEOF = hIsEOF stdin
936
937 -- ---------------------------------------------------------------------------
938 -- Looking ahead
939
940 -- | Computation 'hLookAhead' returns the next character from the handle
941 -- without removing it from the input buffer, blocking until a character
942 -- is available.
943 --
944 -- This operation may fail with:
945 --
946 -- * 'isEOFError' if the end of file has been reached.
947
948 hLookAhead :: Handle -> IO Char
949 hLookAhead handle = do
950 wantReadableHandle "hLookAhead" handle $ \handle_ -> do
951 let ref = haBuffer handle_
952 fd = haFD handle_
953 is_line = haBufferMode handle_ == LineBuffering
954 buf <- readIORef ref
955
956 -- fill up the read buffer if necessary
957 new_buf <- if bufferEmpty buf
958 then fillReadBuffer fd is_line (haIsStream handle_) buf
959 else return buf
960
961 writeIORef ref new_buf
962
963 (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
964 return c
965
966 -- ---------------------------------------------------------------------------
967 -- Buffering Operations
968
969 -- Three kinds of buffering are supported: line-buffering,
970 -- block-buffering or no-buffering. See GHC.IOBase for definition and
971 -- further explanation of what the type represent.
972
973 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
974 -- handle @hdl@ on subsequent reads and writes.
975 --
976 -- If the buffer mode is changed from 'BlockBuffering' or
977 -- 'LineBuffering' to 'NoBuffering', then
978 --
979 -- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
980 --
981 -- * if @hdl@ is not writable, the contents of the buffer is discarded.
982 --
983 -- This operation may fail with:
984 --
985 -- * 'isPermissionError' if the handle has already been used for reading
986 -- or writing and the implementation does not allow the buffering mode
987 -- to be changed.
988
989 hSetBuffering :: Handle -> BufferMode -> IO ()
990 hSetBuffering handle mode =
991 withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do
992 case haType handle_ of
993 ClosedHandle -> ioe_closedHandle
994 _ -> do
995 {- Note:
996 - we flush the old buffer regardless of whether
997 the new buffer could fit the contents of the old buffer
998 or not.
999 - allow a handle's buffering to change even if IO has
1000 occurred (ANSI C spec. does not allow this, nor did
1001 the previous implementation of IO.hSetBuffering).
1002 - a non-standard extension is to allow the buffering
1003 of semi-closed handles to change [sof 6/98]
1004 -}
1005 flushBuffer handle_
1006
1007 let state = initBufferState (haType handle_)
1008 new_buf <-
1009 case mode of
1010 -- we always have a 1-character read buffer for
1011 -- unbuffered handles: it's needed to
1012 -- support hLookAhead.
1013 NoBuffering -> allocateBuffer 1 ReadBuffer
1014 LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state
1015 BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state
1016 BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n
1017 | otherwise -> allocateBuffer n state
1018 writeIORef (haBuffer handle_) new_buf
1019
1020 -- for input terminals we need to put the terminal into
1021 -- cooked or raw mode depending on the type of buffering.
1022 is_tty <- fdIsTTY (haFD handle_)
1023 when (is_tty && isReadableHandleType (haType handle_)) $
1024 case mode of
1025 #ifndef mingw32_TARGET_OS
1026 -- 'raw' mode under win32 is a bit too specialised (and troublesome
1027 -- for most common uses), so simply disable its use here.
1028 NoBuffering -> setCooked (haFD handle_) False
1029 #endif
1030 _ -> setCooked (haFD handle_) True
1031
1032 -- throw away spare buffers, they might be the wrong size
1033 writeIORef (haBuffers handle_) BufferListNil
1034
1035 return (handle_{ haBufferMode = mode })
1036
1037 -- -----------------------------------------------------------------------------
1038 -- hFlush
1039
1040 -- | The action 'hFlush' @hdl@ causes any items buffered for output
1041 -- in handle @hdl@ to be sent immediately to the operating system.
1042 --
1043 -- This operation may fail with:
1044 --
1045 -- * 'isFullError' if the device is full;
1046 --
1047 -- * 'isPermissionError' if a system resource limit would be exceeded.
1048 -- It is unspecified whether the characters in the buffer are discarded
1049 -- or retained under these circumstances.
1050
1051 hFlush :: Handle -> IO ()
1052 hFlush handle =
1053 wantWritableHandle "hFlush" handle $ \ handle_ -> do
1054 buf <- readIORef (haBuffer handle_)
1055 if bufferIsWritable buf && not (bufferEmpty buf)
1056 then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf
1057 writeIORef (haBuffer handle_) flushed_buf
1058 else return ()
1059
1060
1061 -- -----------------------------------------------------------------------------
1062 -- Repositioning Handles
1063
1064 data HandlePosn = HandlePosn Handle HandlePosition
1065
1066 instance Eq HandlePosn where
1067 (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
1068
1069 instance Show HandlePosn where
1070 showsPrec p (HandlePosn h pos) =
1071 showsPrec p h . showString " at position " . shows pos
1072
1073 -- HandlePosition is the Haskell equivalent of POSIX' off_t.
1074 -- We represent it as an Integer on the Haskell side, but
1075 -- cheat slightly in that hGetPosn calls upon a C helper
1076 -- that reports the position back via (merely) an Int.
1077 type HandlePosition = Integer
1078
1079 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
1080 -- @hdl@ as a value of the abstract type 'HandlePosn'.
1081
1082 hGetPosn :: Handle -> IO HandlePosn
1083 hGetPosn handle = do
1084 posn <- hTell handle
1085 return (HandlePosn handle posn)
1086
1087 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
1088 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
1089 -- to the position it held at the time of the call to 'hGetPosn'.
1090 --
1091 -- This operation may fail with:
1092 --
1093 -- * 'isPermissionError' if a system resource limit would be exceeded.
1094
1095 hSetPosn :: HandlePosn -> IO ()
1096 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
1097
1098 -- ---------------------------------------------------------------------------
1099 -- hSeek
1100
1101 -- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
1102 data SeekMode
1103 = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
1104 | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
1105 -- from the current position.
1106 | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
1107 -- from the end of the file.
1108 deriving (Eq, Ord, Ix, Enum, Read, Show)
1109
1110 {- Note:
1111 - when seeking using `SeekFromEnd', positive offsets (>=0) means
1112 seeking at or past EOF.
1113
1114 - we possibly deviate from the report on the issue of seeking within
1115 the buffer and whether to flush it or not. The report isn't exactly
1116 clear here.
1117 -}
1118
1119 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
1120 -- @hdl@ depending on @mode@.
1121 -- The offset @i@ is given in terms of 8-bit bytes.
1122 --
1123 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
1124 -- in the current buffer will first cause any items in the output buffer to be
1125 -- written to the device, and then cause the input buffer to be discarded.
1126 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
1127 -- subset of the possible positioning operations (for instance, it may only
1128 -- be possible to seek to the end of a tape, or to a positive offset from
1129 -- the beginning or current position).
1130 -- It is not possible to set a negative I\/O position, or for
1131 -- a physical file, an I\/O position beyond the current end-of-file.
1132 --
1133 -- This operation may fail with:
1134 --
1135 -- * 'isPermissionError' if a system resource limit would be exceeded.
1136
1137 hSeek :: Handle -> SeekMode -> Integer -> IO ()
1138 hSeek handle mode offset =
1139 wantSeekableHandle "hSeek" handle $ \ handle_ -> do
1140 # ifdef DEBUG_DUMP
1141 puts ("hSeek " ++ show (mode,offset) ++ "\n")
1142 # endif
1143 let ref = haBuffer handle_
1144 buf <- readIORef ref
1145 let r = bufRPtr buf
1146 w = bufWPtr buf
1147 fd = haFD handle_
1148
1149 let do_seek =
1150 throwErrnoIfMinus1Retry_ "hSeek"
1151 (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
1152
1153 whence :: CInt
1154 whence = case mode of
1155 AbsoluteSeek -> sEEK_SET
1156 RelativeSeek -> sEEK_CUR
1157 SeekFromEnd -> sEEK_END
1158
1159 if bufferIsWritable buf
1160 then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf
1161 writeIORef ref new_buf
1162 do_seek
1163 else do
1164
1165 if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r)
1166 then writeIORef ref buf{ bufRPtr = r + fromIntegral offset }
1167 else do
1168
1169 new_buf <- flushReadBuffer (haFD handle_) buf
1170 writeIORef ref new_buf
1171 do_seek
1172
1173
1174 hTell :: Handle -> IO Integer
1175 hTell handle =
1176 wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
1177
1178 #if defined(mingw32_TARGET_OS)
1179 -- urgh, on Windows we have to worry about \n -> \r\n translation,
1180 -- so we can't easily calculate the file position using the
1181 -- current buffer size. Just flush instead.
1182 flushBuffer handle_
1183 #endif
1184 let fd = fromIntegral (haFD handle_)
1185 posn <- fromIntegral `liftM`
1186 throwErrnoIfMinus1Retry "hGetPosn"
1187 (c_lseek fd 0 sEEK_CUR)
1188
1189 let ref = haBuffer handle_
1190 buf <- readIORef ref
1191
1192 let real_posn
1193 | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf)
1194 | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf)
1195 # ifdef DEBUG_DUMP
1196 puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n")
1197 puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n")
1198 # endif
1199 return real_posn
1200
1201 -- -----------------------------------------------------------------------------
1202 -- Handle Properties
1203
1204 -- A number of operations return information about the properties of a
1205 -- handle. Each of these operations returns `True' if the handle has
1206 -- the specified property, and `False' otherwise.
1207
1208 hIsOpen :: Handle -> IO Bool
1209 hIsOpen handle =
1210 withHandle_ "hIsOpen" handle $ \ handle_ -> do
1211 case haType handle_ of
1212 ClosedHandle -> return False
1213 SemiClosedHandle -> return False
1214 _ -> return True
1215
1216 hIsClosed :: Handle -> IO Bool
1217 hIsClosed handle =
1218 withHandle_ "hIsClosed" handle $ \ handle_ -> do
1219 case haType handle_ of
1220 ClosedHandle -> return True
1221 _ -> return False
1222
1223 {- not defined, nor exported, but mentioned
1224 here for documentation purposes:
1225
1226 hSemiClosed :: Handle -> IO Bool
1227 hSemiClosed h = do
1228 ho <- hIsOpen h
1229 hc <- hIsClosed h
1230 return (not (ho || hc))
1231 -}
1232
1233 hIsReadable :: Handle -> IO Bool
1234 hIsReadable (DuplexHandle _ _ _) = return True
1235 hIsReadable handle =
1236 withHandle_ "hIsReadable" handle $ \ handle_ -> do
1237 case haType handle_ of
1238 ClosedHandle -> ioe_closedHandle
1239 SemiClosedHandle -> ioe_closedHandle
1240 htype -> return (isReadableHandleType htype)
1241
1242 hIsWritable :: Handle -> IO Bool
1243 hIsWritable (DuplexHandle _ _ _) = return True
1244 hIsWritable handle =
1245 withHandle_ "hIsWritable" handle $ \ handle_ -> do
1246 case haType handle_ of
1247 ClosedHandle -> ioe_closedHandle
1248 SemiClosedHandle -> ioe_closedHandle
1249 htype -> return (isWritableHandleType htype)
1250
1251 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
1252 -- for @hdl@.
1253
1254 hGetBuffering :: Handle -> IO BufferMode
1255 hGetBuffering handle =
1256 withHandle_ "hGetBuffering" handle $ \ handle_ -> do
1257 case haType handle_ of
1258 ClosedHandle -> ioe_closedHandle
1259 _ ->
1260 -- We're being non-standard here, and allow the buffering
1261 -- of a semi-closed handle to be queried. -- sof 6/98
1262 return (haBufferMode handle_) -- could be stricter..
1263
1264 hIsSeekable :: Handle -> IO Bool
1265 hIsSeekable handle =
1266 withHandle_ "hIsSeekable" handle $ \ handle_ -> do
1267 case haType handle_ of
1268 ClosedHandle -> ioe_closedHandle
1269 SemiClosedHandle -> ioe_closedHandle
1270 AppendHandle -> return False
1271 _ -> do t <- fdType (haFD handle_)
1272 return (t == RegularFile
1273 && (haIsBin handle_
1274 || tEXT_MODE_SEEK_ALLOWED))
1275
1276 -- -----------------------------------------------------------------------------
1277 -- Changing echo status (Non-standard GHC extensions)
1278
1279 -- | Set the echoing status of a handle connected to a terminal (GHC only).
1280
1281 hSetEcho :: Handle -> Bool -> IO ()
1282 hSetEcho handle on = do
1283 isT <- hIsTerminalDevice handle
1284 if not isT
1285 then return ()
1286 else
1287 withHandle_ "hSetEcho" handle $ \ handle_ -> do
1288 case haType handle_ of
1289 ClosedHandle -> ioe_closedHandle
1290 _ -> setEcho (haFD handle_) on
1291
1292 -- | Get the echoing status of a handle connected to a terminal (GHC only).
1293
1294 hGetEcho :: Handle -> IO Bool
1295 hGetEcho handle = do
1296 isT <- hIsTerminalDevice handle
1297 if not isT
1298 then return False
1299 else
1300 withHandle_ "hGetEcho" handle $ \ handle_ -> do
1301 case haType handle_ of
1302 ClosedHandle -> ioe_closedHandle
1303 _ -> getEcho (haFD handle_)
1304
1305 -- | Is the handle connected to a terminal? (GHC only)
1306
1307 hIsTerminalDevice :: Handle -> IO Bool
1308 hIsTerminalDevice handle = do
1309 withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
1310 case haType handle_ of
1311 ClosedHandle -> ioe_closedHandle
1312 _ -> fdIsTTY (haFD handle_)
1313
1314 -- -----------------------------------------------------------------------------
1315 -- hSetBinaryMode
1316
1317 -- | Select binary mode ('True') or text mode ('False') on a open handle.
1318 -- (GHC only; see also 'openBinaryFile'.)
1319
1320 hSetBinaryMode :: Handle -> Bool -> IO ()
1321 hSetBinaryMode handle bin =
1322 withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
1323 do throwErrnoIfMinus1_ "hSetBinaryMode"
1324 (setmode (fromIntegral (haFD handle_)) bin)
1325 return handle_{haIsBin=bin}
1326
1327 foreign import ccall unsafe "__hscore_setmode"
1328 setmode :: CInt -> Bool -> IO CInt
1329
1330 -- -----------------------------------------------------------------------------
1331 -- Duplicating a Handle
1332
1333 -- |Returns a duplicate of the original handle, with its own buffer
1334 -- and file pointer. The original handle's buffer is flushed, including
1335 -- discarding any input data, before the handle is duplicated.
1336
1337 hDuplicate :: Handle -> IO Handle
1338 hDuplicate h@(FileHandle path m) = do
1339 new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
1340 new_m <- newMVar new_h_
1341 return (FileHandle path new_m)
1342 hDuplicate h@(DuplexHandle path r w) = do
1343 new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
1344 new_w <- newMVar new_w_
1345 new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
1346 new_r <- newMVar new_r_
1347 return (DuplexHandle path new_r new_w)
1348
1349 dupHandle_ other_side h_ = do
1350 -- flush the buffer first, so we don't have to copy its contents
1351 flushBuffer h_
1352 new_fd <- c_dup (fromIntegral (haFD h_))
1353 buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
1354 ioref <- newIORef buffer
1355 ioref_buffers <- newIORef BufferListNil
1356
1357 let new_handle_ = h_{ haFD = fromIntegral new_fd,
1358 haBuffer = ioref,
1359 haBuffers = ioref_buffers,
1360 haOtherSide = other_side }
1361 return (h_, new_handle_)
1362
1363 -- -----------------------------------------------------------------------------
1364 -- Replacing a Handle
1365
1366 {- |
1367 Makes the second handle a duplicate of the first handle. The second
1368 handle will be closed first, if it is not already.
1369
1370 This can be used to retarget the standard Handles, for example:
1371
1372 > do h <- openFile "mystdout" WriteMode
1373 > hDuplicateTo h stdout
1374 -}
1375
1376 hDuplicateTo :: Handle -> Handle -> IO ()
1377 hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
1378 withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
1379 _ <- hClose_help h2_
1380 withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
1381 hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
1382 withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
1383 _ <- hClose_help w2_
1384 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
1385 withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
1386 _ <- hClose_help r2_
1387 withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
1388 hDuplicateTo h1 _ =
1389 ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
1390 "handles are incompatible" Nothing)
1391
1392 -- ---------------------------------------------------------------------------
1393 -- showing Handles.
1394 --
1395 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
1396 -- than the (pure) instance of 'Show' for 'Handle'.
1397
1398 hShow :: Handle -> IO String
1399 hShow h@(FileHandle path _) = showHandle' path False h
1400 hShow h@(DuplexHandle path _ _) = showHandle' path True h
1401
1402 showHandle' filepath is_duplex h =
1403 withHandle_ "showHandle" h $ \hdl_ ->
1404 let
1405 showType | is_duplex = showString "duplex (read-write)"
1406 | otherwise = shows (haType hdl_)
1407 in
1408 return
1409 (( showChar '{' .
1410 showHdl (haType hdl_)
1411 (showString "loc=" . showString filepath . showChar ',' .
1412 showString "type=" . showType . showChar ',' .
1413 showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
1414 showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
1415 ) "")
1416 where
1417
1418 showHdl :: HandleType -> ShowS -> ShowS
1419 showHdl ht cont =
1420 case ht of
1421 ClosedHandle -> shows ht . showString "}"
1422 _ -> cont
1423
1424 showBufMode :: Buffer -> BufferMode -> ShowS
1425 showBufMode buf bmo =
1426 case bmo of
1427 NoBuffering -> showString "none"
1428 LineBuffering -> showString "line"
1429 BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
1430 BlockBuffering Nothing -> showString "block " . showParen True (shows def)
1431 where
1432 def :: Int
1433 def = bufSize buf
1434
1435 -- ---------------------------------------------------------------------------
1436 -- debugging
1437
1438 #ifdef DEBUG_DUMP
1439 puts :: String -> IO ()
1440 puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
1441 return ()
1442 #endif
1443
1444 -- -----------------------------------------------------------------------------
1445 -- wrappers to platform-specific constants:
1446
1447 foreign import ccall unsafe "__hscore_supportsTextMode"
1448 tEXT_MODE_SEEK_ALLOWED :: Bool
1449
1450 foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
1451 foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
1452 foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
1453 foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt