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