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.List (span)
  45 import GHC.Num
  46 import GHC.Show
  47 import GHC.Real
  48 import System.IO.Unsafe (unsafePerformIO)
  49 import System.Posix.Internals
  50
  51 c_DEBUG_DUMP :: Bool
  52 c_DEBUG_DUMP = False
  53
  54 iconv_trace :: String -> IO ()
  55 iconv_trace s
  56  | c_DEBUG_DUMP = puts s
  57  | otherwise    = return ()
  58
  59 puts :: String -> IO ()
  60 puts s = do _ <- withCStringLen (s ++ "\n") $ \(p, len) ->
  61                      c_write 1 (castPtr p) (fromIntegral len)
  62             return ()
  63
  64 -- -----------------------------------------------------------------------------
  65 -- iconv encoders/decoders
  66
  67 {-# NOINLINE latin1 #-}
  68 latin1 :: TextEncoding
  69 latin1 = unsafePerformIO (mkTextEncoding "Latin1")
  70
  71 {-# NOINLINE utf8 #-}
  72 utf8 :: TextEncoding
  73 utf8 = unsafePerformIO (mkTextEncoding "UTF8")
  74
  75 {-# NOINLINE utf16 #-}
  76 utf16 :: TextEncoding
  77 utf16 = unsafePerformIO (mkTextEncoding "UTF16")
  78
  79 {-# NOINLINE utf16le #-}
  80 utf16le :: TextEncoding
  81 utf16le = unsafePerformIO (mkTextEncoding "UTF16LE")
  82
  83 {-# NOINLINE utf16be #-}
  84 utf16be :: TextEncoding
  85 utf16be = unsafePerformIO (mkTextEncoding "UTF16BE")
  86
  87 {-# NOINLINE utf32 #-}
  88 utf32 :: TextEncoding
  89 utf32 = unsafePerformIO (mkTextEncoding "UTF32")
  90
  91 {-# NOINLINE utf32le #-}
  92 utf32le :: TextEncoding
  93 utf32le = unsafePerformIO (mkTextEncoding "UTF32LE")
  94
  95 {-# NOINLINE utf32be #-}
  96 utf32be :: TextEncoding
  97 utf32be = unsafePerformIO (mkTextEncoding "UTF32BE")
  98
  99 {-# NOINLINE localeEncoding #-}
 100 localeEncoding :: TextEncoding
 101 localeEncoding = unsafePerformIO $ do
 102    -- Use locale_charset() or nl_langinfo(CODESET) to get the encoding
 103    -- if we have either of them.
 104    cstr <- c_localeEncoding
 105    r <- peekCString cstr
 106    mkTextEncoding r
 107
 108 -- We hope iconv_t is a storable type.  It should be, since it has at least the
 109 -- value -1, which is a possible return value from iconv_open.
 110 type IConv = CLong -- ToDo: (#type iconv_t)
 111
 112 foreign import ccall unsafe "hs_iconv_open"
 113     hs_iconv_open :: CString -> CString -> IO IConv
 114
 115 foreign import ccall unsafe "hs_iconv_close"
 116     hs_iconv_close :: IConv -> IO CInt
 117
 118 foreign import ccall unsafe "hs_iconv"
 119     hs_iconv :: IConv -> Ptr CString -> Ptr CSize -> Ptr CString -> Ptr CSize
 120           -> IO CSize
 121
 122 foreign import ccall unsafe "localeEncoding"
 123     c_localeEncoding :: IO CString
 124
 125 haskellChar :: String
 126 #ifdef WORDS_BIGENDIAN
 127 haskellChar | charSize == 2 = "UTF-16BE"
 128             | otherwise     = "UTF-32BE"
 129 #else
 130 haskellChar | charSize == 2 = "UTF-16LE"
 131             | otherwise     = "UTF-32LE"
 132 #endif
 133
 134 char_shift :: Int
 135 char_shift | charSize == 2 = 1
 136            | otherwise     = 2
 137
 138 mkTextEncoding :: String -> IO TextEncoding
 139 mkTextEncoding charset = do
 140   return (TextEncoding {
 141                 textEncodingName = charset,
 142                 mkTextDecoder = newIConv raw_charset (haskellChar ++ suffix) (iconvDecode cfm),
 143                 mkTextEncoder = newIConv haskellChar charset (iconvEncode cfm)})
 144   where
 145     -- An annoying feature of GNU iconv is that the //PREFIXES only take
 146     -- effect when they appear on the tocode parameter to iconv_open:
 147     (raw_charset, suffix) = span (/= '/') charset
 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 = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt
 157     return BufferCodec{
 158                 encode = fn iconvt,
 159                 close  = iclose,
 160                 -- iconv doesn't supply a way to save/restore the state
 161                 getState = return (),
 162                 setState = const $ return ()
 163                 }
 164
 165 iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem
 166              -> IO (Buffer Word8, Buffer CharBufElem)
 167 iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift
 168
 169 iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8
 170              -> IO (Buffer CharBufElem, Buffer Word8)
 171 iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0
 172
 173 iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int
 174   -> IO (Buffer a, Buffer b)
 175 iconvRecode iconv_t
 176   input@Buffer{  bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_  }  iscale
 177   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow, bufSize=os }  oscale
 178   = do
 179     iconv_trace ("haskelChar=" ++ show haskellChar)
 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 || e == e2BIG
 208           || e == eILSEQ && new_inleft' /= (iw-ir) -> do
 209             iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
 210                 -- Output overflow is harmless
 211                 --
 212                 -- Similarly, we ignore EILSEQ unless we converted no
 213                 -- characters.  Sometimes iconv reports EILSEQ for a
 214                 -- character in the input even when there is no room
 215                 -- in the output; in this case we might be about to
 216                 -- change the encoding anyway, so the following bytes
 217                 -- could very well be in a different encoding.
 218                 -- This also helps with pinpointing EILSEQ errors: we
 219                 -- don't report it until the rest of the characters in
 220                 -- the buffer have been drained.
 221             return (new_input, new_output)
 222
 223         e -> do
 224                 iconv_trace ("iconv returned error: " ++ show (errnoToIOError "iconv" e Nothing Nothing))
 225                 throwErrno "iconvRecoder"
 226                         -- illegal sequence, or some other error
 227
 228 #endif /* !mingw32_HOST_OS */