GHC/IO/Encoding/Iconv.hs

   1 {-# OPTIONS_GHC -fno-implicit-prelude #-}
   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 #include "HsBaseConfig.h"
  29
  30 #if !defined(mingw32_HOST_OS)
  31
  32 #undef DEBUG_DUMP
  33
  34 import Foreign
  35 import Foreign.C
  36 import Data.Maybe
  37 import GHC.Base
  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 $ do
 102 #if HAVE_LANGINFO_H
 103    cstr <- c_localeEncoding -- use nl_langinfo(CODESET) to get the encoding
 104                                -- if we have it
 105    r <- peekCString cstr
 106    mkTextEncoding r
 107 #else
 108    mkTextEncoding "" -- GNU iconv accepts "" to mean the -- locale encoding.
 109 #endif
 110
 111 -- We hope iconv_t is a storable type.  It should be, since it has at least the
 112 -- value -1, which is a possible return value from iconv_open.
 113 type IConv = CLong -- ToDo: (#type iconv_t)
 114
 115 foreign import ccall unsafe "hs_iconv_open"
 116     hs_iconv_open :: CString -> CString -> IO IConv
 117
 118 foreign import ccall unsafe "hs_iconv_close"
 119     hs_iconv_close :: IConv -> IO CInt
 120
 121 foreign import ccall unsafe "hs_iconv"
 122     hs_iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize
 123           -> IO CSize
 124
 125 foreign import ccall unsafe "localeEncoding"
 126     c_localeEncoding :: IO CString
 127
 128 haskellChar :: String
 129 #ifdef WORDS_BIGENDIAN
 130 haskellChar | charSize == 2 = "UTF16BE"
 131             | otherwise     = "UCS-4"
 132 #else
 133 haskellChar | charSize == 2 = "UTF16LE"
 134             | otherwise     = "UCS-4LE"
 135 #endif
 136
 137 char_shift :: Int
 138 char_shift | charSize == 2 = 1
 139            | otherwise     = 2
 140
 141 mkTextEncoding :: String -> IO TextEncoding
 142 mkTextEncoding charset = do
 143   return (TextEncoding {
 144                 mkTextDecoder = newIConv charset haskellChar iconvDecode,
 145                 mkTextEncoder = newIConv haskellChar charset iconvEncode})
 146
 147 newIConv :: String -> String
 148    -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b))
 149    -> IO (BufferCodec a b ())
 150 newIConv from to fn =
 151   withCString from $ \ from_str ->
 152   withCString to   $ \ to_str -> do
 153     iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str
 154     let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt
 155     return BufferCodec{
 156                 encode = fn iconvt,
 157                 close  = iclose,
 158                 -- iconv doesn't supply a way to save/restore the state
 159                 getState = return (),
 160                 setState = const $ return ()
 161                 }
 162
 163 iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem
 164              -> IO (Buffer Word8, Buffer CharBufElem)
 165 iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift
 166
 167 iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8
 168              -> IO (Buffer CharBufElem, Buffer Word8)
 169 iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0
 170
 171 iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int
 172   -> IO (Buffer a, Buffer b)
 173 iconvRecode iconv_t
 174   input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_  }  iscale
 175   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow, bufSize=os }  oscale
 176   = do
 177     iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input))
 178     iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output))
 179     withRawBuffer iraw $ \ piraw -> do
 180     withRawBuffer oraw $ \ poraw -> do
 181     with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do
 182     with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do
 183     with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do
 184     with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do
 185       res <- hs_iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft
 186       new_inleft  <- peek p_inleft
 187       new_outleft <- peek p_outleft
 188       let
 189           new_inleft'  = fromIntegral new_inleft `shiftR` iscale
 190           new_outleft' = fromIntegral new_outleft `shiftR` oscale
 191           new_input
 192             | new_inleft == 0  = input { bufL = 0, bufR = 0 }
 193             | otherwise        = input { bufL = iw - new_inleft' }
 194           new_output = output{ bufR = os - new_outleft' }
 195       iconv_trace ("iconv res=" ++ show res)
 196       iconv_trace ("iconvRecode after,  input=" ++ show (summaryBuffer new_input))
 197       iconv_trace ("iconvRecode after,  output=" ++ show (summaryBuffer new_output))
 198       if (res /= -1)
 199         then do -- all input translated
 200            return (new_input, new_output)
 201         else do
 202       errno <- getErrno
 203       case errno of
 204         e |  e == eINVAL
 205           || (e == e2BIG || e == eILSEQ) && new_inleft' /= (iw-ir) -> do
 206             iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
 207                 -- Output overflow is relatively harmless, unless
 208                 -- we made no progress at all.
 209                 --
 210                 -- Similarly, we ignore EILSEQ unless we converted no
 211                 -- characters.  Sometimes iconv reports EILSEQ for a
 212                 -- character in the input even when there is no room
 213                 -- in the output; in this case we might be about to
 214                 -- change the encoding anyway, so the following bytes
 215                 -- could very well be in a different encoding.
 216                 -- This also helps with pinpointing EILSEQ errors: we
 217                 -- don't report it until the rest of the characters in
 218                 -- the buffer have been drained.
 219             return (new_input, new_output)
 220
 221         _other ->
 222                 throwErrno "iconvRecoder"
 223                         -- illegal sequence, or some other error
 224
 225 #endif /* !mingw32_HOST_OS */