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