1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- 10-- -- 11-- GNAT is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32package body Ada.Strings.UTF_Encoding.Conversions is 33 use Interfaces; 34 35 -- Convert from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE 36 37 function Convert 38 (Item : UTF_String; 39 Input_Scheme : Encoding_Scheme; 40 Output_Scheme : Encoding_Scheme; 41 Output_BOM : Boolean := False) return UTF_String 42 is 43 begin 44 -- Nothing to do if identical schemes, but for UTF_8 we need to 45 -- handle overlong encodings, so need to do the full conversion. 46 47 if Input_Scheme = Output_Scheme 48 and then Input_Scheme /= UTF_8 49 then 50 return Item; 51 52 -- For remaining cases, one or other of the operands is UTF-16BE/LE 53 -- encoded, or we have the UTF-8 to UTF-8 case where we must handle 54 -- overlong encodings. In all cases, go through UTF-16 intermediate. 55 56 else 57 return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)), 58 Output_Scheme, Output_BOM); 59 end if; 60 end Convert; 61 62 -- Convert from UTF-8/UTF-16BE/LE to UTF-16 63 64 function Convert 65 (Item : UTF_String; 66 Input_Scheme : Encoding_Scheme; 67 Output_BOM : Boolean := False) return UTF_16_Wide_String 68 is 69 begin 70 if Input_Scheme = UTF_8 then 71 return Convert (Item, Output_BOM); 72 else 73 return To_UTF_16 (Item, Input_Scheme, Output_BOM); 74 end if; 75 end Convert; 76 77 -- Convert from UTF-8 to UTF-16 78 79 function Convert 80 (Item : UTF_8_String; 81 Output_BOM : Boolean := False) return UTF_16_Wide_String 82 is 83 Result : UTF_16_Wide_String (1 .. Item'Length + 1); 84 -- Maximum length of result, including possible BOM 85 86 Len : Natural := 0; 87 -- Number of characters stored so far in Result 88 89 Iptr : Natural; 90 -- Next character to process in Item 91 92 C : Unsigned_8; 93 -- Input UTF-8 code 94 95 R : Unsigned_16; 96 -- Output UTF-16 code 97 98 procedure Get_Continuation; 99 -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6 100 -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr 101 -- is incremented. Raises exception if continuation byte does not exist 102 -- or is invalid. 103 104 ---------------------- 105 -- Get_Continuation -- 106 ---------------------- 107 108 procedure Get_Continuation is 109 begin 110 if Iptr > Item'Last then 111 Raise_Encoding_Error (Iptr - 1); 112 113 else 114 C := To_Unsigned_8 (Item (Iptr)); 115 Iptr := Iptr + 1; 116 117 if C < 2#10_000000# or else C > 2#10_111111# then 118 Raise_Encoding_Error (Iptr - 1); 119 120 else 121 R := 122 Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); 123 end if; 124 end if; 125 end Get_Continuation; 126 127 -- Start of processing for Convert 128 129 begin 130 -- Output BOM if required 131 132 if Output_BOM then 133 Len := Len + 1; 134 Result (Len) := BOM_16 (1); 135 end if; 136 137 -- Skip OK BOM 138 139 Iptr := Item'First; 140 141 if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then 142 Iptr := Iptr + 3; 143 144 -- Error if bad BOM 145 146 elsif Item'Length >= 2 147 and then (Item (Iptr .. Iptr + 1) = BOM_16BE 148 or else 149 Item (Iptr .. Iptr + 1) = BOM_16LE) 150 then 151 Raise_Encoding_Error (Iptr); 152 153 -- No BOM present 154 155 else 156 Iptr := Item'First; 157 end if; 158 159 while Iptr <= Item'Last loop 160 C := To_Unsigned_8 (Item (Iptr)); 161 Iptr := Iptr + 1; 162 163 -- Codes in the range 16#00# .. 16#7F# 164 -- UTF-8: 0xxxxxxx 165 -- UTF-16: 00000000_0xxxxxxx 166 167 if C <= 16#7F# then 168 Len := Len + 1; 169 Result (Len) := Wide_Character'Val (C); 170 171 -- No initial code can be of the form 10xxxxxx. Such codes are used 172 -- only for continuations. 173 174 elsif C <= 2#10_111111# then 175 Raise_Encoding_Error (Iptr - 1); 176 177 -- Codes in the range 16#80# .. 16#7FF# 178 -- UTF-8: 110yyyxx 10xxxxxx 179 -- UTF-16: 00000yyy_xxxxxxxx 180 181 elsif C <= 2#110_11111# then 182 R := Unsigned_16 (C and 2#000_11111#); 183 Get_Continuation; 184 Len := Len + 1; 185 Result (Len) := Wide_Character'Val (R); 186 187 -- Codes in the range 16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF# 188 -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx 189 -- UTF-16: yyyyyyyy_xxxxxxxx 190 191 elsif C <= 2#1110_1111# then 192 R := Unsigned_16 (C and 2#0000_1111#); 193 Get_Continuation; 194 Get_Continuation; 195 Len := Len + 1; 196 Result (Len) := Wide_Character'Val (R); 197 198 -- Make sure that we don't have a result in the forbidden range 199 -- reserved for UTF-16 surrogate characters. 200 201 if R in 16#D800# .. 16#DF00# then 202 Raise_Encoding_Error (Iptr - 3); 203 end if; 204 205 -- Codes in the range 16#10000# .. 16#10FFFF# 206 -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx 207 -- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx 208 -- Note: zzzz in the output is input zzzzz - 1 209 210 elsif C <= 2#11110_111# then 211 R := Unsigned_16 (C and 2#00000_111#); 212 Get_Continuation; 213 214 -- R now has zzzzzyyyy 215 216 -- At this stage, we check for the case where we have an overlong 217 -- encoding, and the encoded value in fact lies in the single word 218 -- range (16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF#). This means 219 -- that the result fits in a single result word. 220 221 if R <= 2#1111# then 222 Get_Continuation; 223 Get_Continuation; 224 225 -- Make sure we are not in the forbidden surrogate range 226 227 if R in 16#D800# .. 16#DF00# then 228 Raise_Encoding_Error (Iptr - 3); 229 end if; 230 231 -- Otherwise output a single UTF-16 value 232 233 Len := Len + 1; 234 Result (Len) := Wide_Character'Val (R); 235 236 -- Here for normal case (code value > 16#FFFF and zzzzz non-zero) 237 238 else 239 -- Subtract 1 from input zzzzz value to get output zzzz value 240 241 R := R - 2#0000_1_0000#; 242 243 -- R now has zzzzyyyy (zzzz minus one for the output) 244 245 Get_Continuation; 246 247 -- R now has zzzzyy_yyyyyyxx 248 249 Len := Len + 1; 250 Result (Len) := 251 Wide_Character'Val 252 (2#110110_00_0000_0000# or Shift_Right (R, 4)); 253 254 R := R and 2#1111#; 255 Get_Continuation; 256 Len := Len + 1; 257 Result (Len) := 258 Wide_Character'Val (2#110111_00_0000_0000# or R); 259 end if; 260 261 -- Any other code is an error 262 263 else 264 Raise_Encoding_Error (Iptr - 1); 265 end if; 266 end loop; 267 268 return Result (1 .. Len); 269 end Convert; 270 271 -- Convert from UTF-16 to UTF-8/UTF-16-BE/LE 272 273 function Convert 274 (Item : UTF_16_Wide_String; 275 Output_Scheme : Encoding_Scheme; 276 Output_BOM : Boolean := False) return UTF_String 277 is 278 begin 279 if Output_Scheme = UTF_8 then 280 return Convert (Item, Output_BOM); 281 else 282 return From_UTF_16 (Item, Output_Scheme, Output_BOM); 283 end if; 284 end Convert; 285 286 -- Convert from UTF-16 to UTF-8 287 288 function Convert 289 (Item : UTF_16_Wide_String; 290 Output_BOM : Boolean := False) return UTF_8_String 291 is 292 Result : UTF_8_String (1 .. 3 * Item'Length + 3); 293 -- Worst case is 3 output codes for each input code + BOM space 294 295 Len : Natural; 296 -- Number of result codes stored 297 298 Iptr : Natural; 299 -- Pointer to next input character 300 301 C1, C2 : Unsigned_16; 302 303 zzzzz : Unsigned_16; 304 yyyyyyyy : Unsigned_16; 305 xxxxxxxx : Unsigned_16; 306 -- Components of double length case 307 308 begin 309 Iptr := Item'First; 310 311 -- Skip BOM at start of input 312 313 if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then 314 Iptr := Iptr + 1; 315 end if; 316 317 -- Generate output BOM if required 318 319 if Output_BOM then 320 Result (1 .. 3) := BOM_8; 321 Len := 3; 322 else 323 Len := 0; 324 end if; 325 326 -- Loop through input 327 328 while Iptr <= Item'Last loop 329 C1 := To_Unsigned_16 (Item (Iptr)); 330 Iptr := Iptr + 1; 331 332 -- Codes in the range 16#0000# - 16#007F# 333 -- UTF-16: 000000000xxxxxxx 334 -- UTF-8: 0xxxxxxx 335 336 if C1 <= 16#007F# then 337 Result (Len + 1) := Character'Val (C1); 338 Len := Len + 1; 339 340 -- Codes in the range 16#80# - 16#7FF# 341 -- UTF-16: 00000yyyxxxxxxxx 342 -- UTF-8: 110yyyxx 10xxxxxx 343 344 elsif C1 <= 16#07FF# then 345 Result (Len + 1) := 346 Character'Val 347 (2#110_00000# or Shift_Right (C1, 6)); 348 Result (Len + 2) := 349 Character'Val 350 (2#10_000000# or (C1 and 2#00_111111#)); 351 Len := Len + 2; 352 353 -- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF# 354 -- UTF-16: yyyyyyyyxxxxxxxx 355 -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx 356 357 elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then 358 Result (Len + 1) := 359 Character'Val 360 (2#1110_0000# or Shift_Right (C1, 12)); 361 Result (Len + 2) := 362 Character'Val 363 (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#)); 364 Result (Len + 3) := 365 Character'Val 366 (2#10_000000# or (C1 and 2#00_111111#)); 367 Len := Len + 3; 368 369 -- Codes in the range 16#10000# - 16#10FFFF# 370 -- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx 371 -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx 372 -- Note: zzzzz in the output is input zzzz + 1 373 374 elsif C1 <= 2#110110_11_11111111# then 375 if Iptr > Item'Last then 376 Raise_Encoding_Error (Iptr - 1); 377 else 378 C2 := To_Unsigned_16 (Item (Iptr)); 379 Iptr := Iptr + 1; 380 end if; 381 382 if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then 383 Raise_Encoding_Error (Iptr - 1); 384 end if; 385 386 zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1; 387 yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#) 388 or 389 (Shift_Right (C2, 8) and 2#000000_11#)); 390 xxxxxxxx := C2 and 2#11111111#; 391 392 Result (Len + 1) := 393 Character'Val 394 (2#11110_000# or (Shift_Right (zzzzz, 2))); 395 Result (Len + 2) := 396 Character'Val 397 (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) 398 or Shift_Right (yyyyyyyy, 4)); 399 Result (Len + 3) := 400 Character'Val 401 (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) 402 or Shift_Right (xxxxxxxx, 6)); 403 Result (Len + 4) := 404 Character'Val 405 (2#10_000000# or (xxxxxxxx and 2#00_111111#)); 406 Len := Len + 4; 407 408 -- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st) 409 410 else 411 Raise_Encoding_Error (Iptr - 2); 412 end if; 413 end loop; 414 415 return Result (1 .. Len); 416 end Convert; 417 418end Ada.Strings.UTF_Encoding.Conversions; 419