GHC/IO/Encoding/Iconv.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
   2 -----------------------------------------------------------------------------
   3 -- |
   4 -- Module      :  GHC.IO.Encoding.Iconv
   5 -- Copyright   :  (c) The University of Glasgow, 2008-2009
   6 -- License     :  see libraries/base/LICENSE
   7 --
   8 -- Maintainer  :  libraries@haskell.org
   9 -- Stability   :  internal
  10 -- Portability :  non-portable
  11 --
  12 -- This module provides text encoding/decoding using iconv
  13 --
  14 -----------------------------------------------------------------------------
  15
  16 -- #hide
  17 module GHC.IO.Encoding.Iconv (
  18 #if !defined(mingw32_HOST_OS)
  19    mkTextEncoding,
  20    latin1,
  21    utf8,
  22    utf16, utf16le, utf16be,
  23    utf32, utf32le, utf32be,
  24    localeEncoding
  25 #endif
  26  ) where
  27
  28 #if !defined(mingw32_HOST_OS)
  29
  30 #undef DEBUG_DUMP
  31
  32 import Foreign
  33 import Foreign.C
  34 import Data.Maybe
  35 import GHC.Base
  36 import GHC.Word
  37 import GHC.IO
  38 import GHC.IO.Buffer
  39 import GHC.IO.Encoding.Types
  40 import GHC.Num
  41 import GHC.Show
  42 import GHC.Real
  43 #ifdef DEBUG_DUMP
  44 import System.Posix.Internals
  45 #endif
  46
  47 iconv_trace :: String -> IO ()
  48
  49 #ifdef DEBUG_DUMP
  50
  51 iconv_trace s = puts s
  52
  53 puts :: String -> IO ()
  54 puts s = do withCStringLen (s++"\n") $ \(p,len) ->
  55                 c_write 1 p (fromIntegral len)
  56             return ()
  57
  58 #else
  59
  60 iconv_trace _ = return ()
  61
  62 #endif
  63
  64 -- -----------------------------------------------------------------------------
  65 -- iconv encoders/decoders
  66
  67 {-# NOINLINE latin1 #-}
  68 latin1 :: TextEncoding
  69 latin1 = unsafePerformIO (mkTextEncoding "Latin1")
  70
  71 {-# NOINLINE utf8 #-}
  72 utf8 :: TextEncoding
  73 utf8 = unsafePerformIO (mkTextEncoding "UTF8")
  74
  75 {-# NOINLINE utf16 #-}
  76 utf16 :: TextEncoding
  77 utf16 = unsafePerformIO (mkTextEncoding "UTF16")
  78
  79 {-# NOINLINE utf16le #-}
  80 utf16le :: TextEncoding
  81 utf16le = unsafePerformIO (mkTextEncoding "UTF16LE")
  82
  83 {-# NOINLINE utf16be #-}
  84 utf16be :: TextEncoding
  85 utf16be = unsafePerformIO (mkTextEncoding "UTF16BE")
  86
  87 {-# NOINLINE utf32 #-}
  88 utf32 :: TextEncoding
  89 utf32 = unsafePerformIO (mkTextEncoding "UTF32")
  90
  91 {-# NOINLINE utf32le #-}
  92 utf32le :: TextEncoding
  93 utf32le = unsafePerformIO (mkTextEncoding "UTF32LE")
  94
  95 {-# NOINLINE utf32be #-}
  96 utf32be :: TextEncoding
  97 utf32be = unsafePerformIO (mkTextEncoding "UTF32BE")
  98
  99 {-# NOINLINE localeEncoding #-}
 100 localeEncoding :: TextEncoding
 101 localeEncoding = unsafePerformIO (mkTextEncoding "")
 102
 103 -- We hope iconv_t is a storable type.  It should be, since it has at least the
 104 -- value -1, which is a possible return value from iconv_open.
 105 type IConv = CLong -- ToDo: (#type iconv_t)
 106
 107 foreign import ccall unsafe "iconv_open"
 108     iconv_open :: CString -> CString -> IO IConv
 109
 110 foreign import ccall unsafe "iconv_close"
 111     iconv_close :: IConv -> IO CInt
 112
 113 foreign import ccall unsafe "iconv"
 114     iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize
 115           -> IO CSize
 116
 117 haskellChar :: String
 118 #ifdef WORDS_BIGENDIAN
 119 haskellChar | charSize == 2 = "UTF16BE"
 120             | otherwise     = "UCS-4"
 121 #else
 122 haskellChar | charSize == 2 = "UTF16LE"
 123             | otherwise     = "UCS-4LE"
 124 #endif
 125
 126 char_shift :: Int
 127 char_shift | charSize == 2 = 1
 128            | otherwise     = 2
 129
 130 mkTextEncoding :: String -> IO TextEncoding
 131 mkTextEncoding charset = do
 132   return (TextEncoding {
 133                 mkTextDecoder = newIConv charset haskellChar iconvDecode,
 134                 mkTextEncoder = newIConv haskellChar charset iconvEncode})
 135
 136 newIConv :: String -> String
 137    -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b))
 138    -> IO (BufferCodec a b ())
 139 newIConv from to fn =
 140   withCString from $ \ from_str ->
 141   withCString to   $ \ to_str -> do
 142     iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ iconv_open to_str from_str
 143     let iclose = do throwErrnoIfMinus1 "Iconv.close" $ iconv_close iconvt
 144                     return ()
 145     return BufferCodec{
 146                 encode = fn iconvt,
 147                 close  = iclose,
 148                 -- iconv doesn't supply a way to save/restore the state
 149                 getState = return (),
 150                 setState = const $ return ()
 151                 }
 152
 153 iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem
 154              -> IO (Buffer Word8, Buffer CharBufElem)
 155 iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift
 156
 157 iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8
 158              -> IO (Buffer CharBufElem, Buffer Word8)
 159 iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0
 160
 161 iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int
 162   -> IO (Buffer a, Buffer b)
 163 iconvRecode iconv_t
 164   input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_  }  iscale
 165   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow, bufSize=os }  oscale
 166   = do
 167     iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input))
 168     iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output))
 169     withRawBuffer iraw $ \ piraw -> do
 170     withRawBuffer oraw $ \ poraw -> do
 171     with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do
 172     with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do
 173     with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do
 174     with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do
 175       res <- iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft
 176       new_inleft  <- peek p_inleft
 177       new_outleft <- peek p_outleft
 178       let
 179           new_inleft'  = fromIntegral new_inleft `shiftR` iscale
 180           new_outleft' = fromIntegral new_outleft `shiftR` oscale
 181           new_input
 182             | new_inleft == 0  = input { bufL = 0, bufR = 0 }
 183             | otherwise        = input { bufL = iw - new_inleft' }
 184           new_output = output{ bufR = os - new_outleft' }
 185       iconv_trace ("iconv res=" ++ show res)
 186       iconv_trace ("iconvRecode after,  input=" ++ show (summaryBuffer new_input))
 187       iconv_trace ("iconvRecode after,  output=" ++ show (summaryBuffer new_output))
 188       if (res /= -1)
 189         then do -- all input translated
 190            return (new_input, new_output)
 191         else do
 192       errno <- getErrno
 193       case errno of
 194         e |  e == eINVAL
 195           || (e == e2BIG || e == eILSEQ) && new_inleft' /= (iw-ir) -> do
 196             iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
 197                 -- Output overflow is relatively harmless, unless
 198                 -- we made no progress at all.
 199                 --
 200                 -- Similarly, we ignore EILSEQ unless we converted no
 201                 -- characters.  Sometimes iconv reports EILSEQ for a
 202                 -- character in the input even when there is no room
 203                 -- in the output; in this case we might be about to
 204                 -- change the encoding anyway, so the following bytes
 205                 -- could very well be in a different encoding.
 206                 -- This also helps with pinpointing EILSEQ errors: we
 207                 -- don't report it until the rest of the characters in
 208                 -- the buffer have been drained.
 209             return (new_input, new_output)
 210
 211         _other ->
 212                 throwErrno "iconvRecoder"
 213                         -- illegal sequence, or some other error
 214
 215 #endif /* !mingw32_HOST_OS */