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