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