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