1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME COMPONENTS --
5 -- A D A . S T R I N G S . U T F _ E N C O D I N G --
9 -- Copyright (C) 2010-2024, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 package body Ada
.Strings
.UTF_Encoding
is
41 Default
: Encoding_Scheme
:= UTF_8
) return Encoding_Scheme
44 if Item
'Length >= 2 then
45 if Item
(Item
'First .. Item
'First + 1) = BOM_16BE
then
48 elsif Item
(Item
'First .. Item
'First + 1) = BOM_16LE
then
51 elsif Item
'Length >= 3
52 and then Item
(Item
'First .. Item
'First + 2) = BOM_8
66 (Item
: UTF_16_Wide_String
;
67 Output_Scheme
: UTF_XE_Encoding
;
68 Output_BOM
: Boolean := False) return UTF_String
70 BSpace
: constant Natural := 2 * Boolean'Pos (Output_BOM
);
71 Result
: UTF_String
(1 .. 2 * Item
'Length + BSpace
);
79 (if Output_Scheme
= UTF_16BE
then BOM_16BE
else BOM_16LE
);
89 if Iptr
<= Item
'Last and then Item
(Iptr
) = BOM_16
(1) then
95 if Output_Scheme
= UTF_16BE
then
96 while Iptr
<= Item
'Last loop
97 C
:= To_Unsigned_16
(Item
(Iptr
));
98 Result
(Len
+ 1) := Character'Val (Shift_Right
(C
, 8));
99 Result
(Len
+ 2) := Character'Val (C
and 16#
00_FF#
);
107 while Iptr
<= Item
'Last loop
108 C
:= To_Unsigned_16
(Item
(Iptr
));
109 Result
(Len
+ 1) := Character'Val (C
and 16#
00_FF#
);
110 Result
(Len
+ 2) := Character'Val (Shift_Right
(C
, 8));
116 return Result
(1 .. Len
);
119 --------------------------
120 -- Raise_Encoding_Error --
121 --------------------------
123 procedure Raise_Encoding_Error
(Index
: Natural) is
124 Val
: constant String := Index
'Img;
126 raise Encoding_Error
with
127 "bad input at Item (" & Val
(Val
'First + 1 .. Val
'Last) & ')';
128 end Raise_Encoding_Error
;
136 Input_Scheme
: UTF_XE_Encoding
;
137 Output_BOM
: Boolean := False) return UTF_16_Wide_String
139 Result
: UTF_16_Wide_String
(1 .. Item
'Length / 2 + 1);
144 if Item
'Length mod 2 /= 0 then
145 raise Encoding_Error
with "UTF-16BE/LE string has odd length";
148 -- Deal with input BOM, skip if OK, error if bad BOM
152 if Item
'Length >= 2 then
153 if Item
(Iptr
.. Iptr
+ 1) = BOM_16BE
then
154 if Input_Scheme
= UTF_16BE
then
157 Raise_Encoding_Error
(Iptr
);
160 elsif Item
(Iptr
.. Iptr
+ 1) = BOM_16LE
then
161 if Input_Scheme
= UTF_16LE
then
164 Raise_Encoding_Error
(Iptr
);
167 elsif Item
'Length >= 3 and then Item
(Iptr
.. Iptr
+ 2) = BOM_8
then
168 Raise_Encoding_Error
(Iptr
);
172 -- Output BOM if specified
175 Result
(1) := BOM_16
(1);
183 if Input_Scheme
= UTF_16BE
then
184 while Iptr
< Item
'Last loop
188 (Character'Pos (Item
(Iptr
)) * 256 +
189 Character'Pos (Item
(Iptr
+ 1)));
196 while Iptr
< Item
'Last loop
200 (Character'Pos (Item
(Iptr
)) +
201 Character'Pos (Item
(Iptr
+ 1)) * 256);
206 return Result
(1 .. Len
);
209 end Ada
.Strings
.UTF_Encoding
;