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                 textEncodingName = charset,
 136                 mkTextDecoder = newIConv charset haskellChar iconvDecode,
 137                 mkTextEncoder = newIConv haskellChar charset iconvEncode})
 138
 139 newIConv :: String -> String
 140    -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b))
 141    -> IO (BufferCodec a b ())
 142 newIConv from to fn =
 143   withCString from $ \ from_str ->
 144   withCString to   $ \ to_str -> do
 145     iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str
 146     let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt
 147     return BufferCodec{
 148                 encode = fn iconvt,
 149                 close  = iclose,
 150                 -- iconv doesn't supply a way to save/restore the state
 151                 getState = return (),
 152                 setState = const $ return ()
 153                 }
 154
 155 iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem
 156              -> IO (Buffer Word8, Buffer CharBufElem)
 157 iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift
 158
 159 iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8
 160              -> IO (Buffer CharBufElem, Buffer Word8)
 161 iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0
 162
 163 iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int
 164   -> IO (Buffer a, Buffer b)
 165 iconvRecode iconv_t
 166   input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_  }  iscale
 167   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow, bufSize=os }  oscale
 168   = do
 169     iconv_trace ("haskelChar=" ++ show haskellChar)
 170     iconv_trace ("iconvRecode before, input=" ++ show (summaryBuffer input))
 171     iconv_trace ("iconvRecode before, output=" ++ show (summaryBuffer output))
 172     withRawBuffer iraw $ \ piraw -> do
 173     withRawBuffer oraw $ \ poraw -> do
 174     with (piraw `plusPtr` (ir `shiftL` iscale)) $ \ p_inbuf -> do
 175     with (poraw `plusPtr` (ow `shiftL` oscale)) $ \ p_outbuf -> do
 176     with (fromIntegral ((iw-ir) `shiftL` iscale)) $ \ p_inleft -> do
 177     with (fromIntegral ((os-ow) `shiftL` oscale)) $ \ p_outleft -> do
 178       res <- hs_iconv iconv_t p_inbuf p_inleft p_outbuf p_outleft
 179       new_inleft  <- peek p_inleft
 180       new_outleft <- peek p_outleft
 181       let
 182           new_inleft'  = fromIntegral new_inleft `shiftR` iscale
 183           new_outleft' = fromIntegral new_outleft `shiftR` oscale
 184           new_input
 185             | new_inleft == 0  = input { bufL = 0, bufR = 0 }
 186             | otherwise        = input { bufL = iw - new_inleft' }
 187           new_output = output{ bufR = os - new_outleft' }
 188       iconv_trace ("iconv res=" ++ show res)
 189       iconv_trace ("iconvRecode after,  input=" ++ show (summaryBuffer new_input))
 190       iconv_trace ("iconvRecode after,  output=" ++ show (summaryBuffer new_output))
 191       if (res /= -1)
 192         then do -- all input translated
 193            return (new_input, new_output)
 194         else do
 195       errno <- getErrno
 196       case errno of
 197         e |  e == eINVAL || e == e2BIG
 198           || e == eILSEQ && new_inleft' /= (iw-ir) -> do
 199             iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
 200                 -- Output overflow is harmless
 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         e -> do
 214                 iconv_trace ("iconv returned error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
 215                 throwErrno "iconvRecoder"
 216                         -- illegal sequence, or some other error
 217
 218 #endif /* !mingw32_HOST_OS */