GHC/IO/Encoding/Iconv.hs

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