GHC/IO/Encoding/Iconv.hs

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