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