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    -- Use locale_charset() or nl_langinfo(CODESET) to get the encoding
  96    -- if we have either of them.
  97    cstr <- c_localeEncoding
  98    r <- peekCString cstr
  99    mkTextEncoding r
 100
 101 -- We hope iconv_t is a storable type.  It should be, since it has at least the
 102 -- value -1, which is a possible return value from iconv_open.
 103 type IConv = CLong -- ToDo: (#type iconv_t)
 104
 105 foreign import ccall unsafe "hs_iconv_open"
 106     hs_iconv_open :: CString -> CString -> IO IConv
 107
 108 foreign import ccall unsafe "hs_iconv_close"
 109     hs_iconv_close :: IConv -> IO CInt
 110
 111 foreign import ccall unsafe "hs_iconv"
 112     hs_iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize
 113           -> IO CSize
 114
 115 foreign import ccall unsafe "localeEncoding"
 116     c_localeEncoding :: IO CString
 117
 118 haskellChar :: String
 119 #ifdef WORDS_BIGENDIAN
 120 haskellChar | charSize == 2 = "UTF-16BE"
 121             | otherwise     = "UTF-32BE"
 122 #else
 123 haskellChar | charSize == 2 = "UTF-16LE"
 124             | otherwise     = "UTF-32LE"
 125 #endif
 126
 127 char_shift :: Int
 128 char_shift | charSize == 2 = 1
 129            | otherwise     = 2
 130
 131 mkTextEncoding :: String -> IO TextEncoding
 132 mkTextEncoding charset = do
 133   return (TextEncoding {
 134                 mkTextDecoder = newIConv charset haskellChar iconvDecode,
 135                 mkTextEncoder = newIConv haskellChar charset iconvEncode})
 136
 137 newIConv :: String -> String
 138    -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b))
 139    -> IO (BufferCodec a b ())
 140 newIConv from to fn =
 141   withCString from $ \ from_str ->
 142   withCString to   $ \ to_str -> do
 143     iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str
 144     let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt
 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 ("haskelChar=" ++ show haskellChar)
 168     iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input))
 169     iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output))
 170     withRawBuffer iraw $ \ piraw -> do
 171     withRawBuffer oraw $ \ poraw -> do
 172     with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do
 173     with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do
 174     with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do
 175     with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do
 176       res <- hs_iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft
 177       new_inleft  <- peek p_inleft
 178       new_outleft <- peek p_outleft
 179       let
 180           new_inleft'  = fromIntegral new_inleft `shiftR` iscale
 181           new_outleft' = fromIntegral new_outleft `shiftR` oscale
 182           new_input
 183             | new_inleft == 0  = input { bufL = 0, bufR = 0 }
 184             | otherwise        = input { bufL = iw - new_inleft' }
 185           new_output = output{ bufR = os - new_outleft' }
 186       iconv_trace ("iconv res=" ++ show res)
 187       iconv_trace ("iconvRecode after,  input=" ++ show (summaryBuffer new_input))
 188       iconv_trace ("iconvRecode after,  output=" ++ show (summaryBuffer new_output))
 189       if (res /= -1)
 190         then do -- all input translated
 191            return (new_input, new_output)
 192         else do
 193       errno <- getErrno
 194       case errno of
 195         e |  e == eINVAL
 196           || (e == e2BIG || e == eILSEQ) && new_inleft' /= (iw-ir) -> do
 197             iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
 198                 -- Output overflow is relatively harmless, unless
 199                 -- we made no progress at all.
 200                 --
 201                 -- Similarly, we ignore EILSEQ unless we converted no
 202                 -- characters.  Sometimes iconv reports EILSEQ for a
 203                 -- character in the input even when there is no room
 204                 -- in the output; in this case we might be about to
 205                 -- change the encoding anyway, so the following bytes
 206                 -- could very well be in a different encoding.
 207                 -- This also helps with pinpointing EILSEQ errors: we
 208                 -- don't report it until the rest of the characters in
 209                 -- the buffer have been drained.
 210             return (new_input, new_output)
 211
 212         _other ->
 213                 throwErrno "iconvRecoder"
 214                         -- illegal sequence, or some other error
 215
 216 #endif /* !mingw32_HOST_OS */