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