Line data Source code
1 : !> XML entity escaping and unescaping utilities.
2 : module hsd_data_xml_escape
3 : implicit none(type, external)
4 : private
5 :
6 : public :: xml_escape_text, xml_escape_attrib, xml_unescape
7 :
8 : contains
9 :
10 : !> Escape text content for XML (&, <, >).
11 1263 : pure function xml_escape_text(str) result(escaped)
12 : character(len=*), intent(in) :: str
13 : character(len=:), allocatable :: escaped
14 :
15 1263 : integer :: ii, out_len
16 :
17 : ! First pass: compute output length
18 1263 : out_len = 0
19 79165 : do ii = 1, len(str)
20 79165 : select case (str(ii:ii))
21 : case ("&")
22 6 : out_len = out_len + 5 ! &
23 : case ("<")
24 6 : out_len = out_len + 4 ! <
25 : case (">")
26 6 : out_len = out_len + 4 ! >
27 : case default
28 77902 : out_len = out_len + 1
29 : end select
30 : end do
31 :
32 : ! Second pass: build escaped string
33 1263 : allocate(character(len=out_len) :: escaped)
34 1263 : out_len = 0
35 79165 : do ii = 1, len(str)
36 79165 : select case (str(ii:ii))
37 : case ("&")
38 6 : escaped(out_len + 1:out_len + 5) = "&"
39 6 : out_len = out_len + 5
40 : case ("<")
41 6 : escaped(out_len + 1:out_len + 4) = "<"
42 6 : out_len = out_len + 4
43 : case (">")
44 6 : escaped(out_len + 1:out_len + 4) = ">"
45 6 : out_len = out_len + 4
46 : case default
47 77884 : out_len = out_len + 1
48 77902 : escaped(out_len:out_len) = str(ii:ii)
49 : end select
50 : end do
51 :
52 2526 : end function xml_escape_text
53 :
54 : !> Escape attribute value for XML (&, <, >, ", ').
55 52 : pure function xml_escape_attrib(str) result(escaped)
56 : character(len=*), intent(in) :: str
57 : character(len=:), allocatable :: escaped
58 :
59 52 : integer :: ii, out_len
60 :
61 : ! First pass: compute output length
62 52 : out_len = 0
63 382 : do ii = 1, len(str)
64 382 : select case (str(ii:ii))
65 : case ("&")
66 0 : out_len = out_len + 5 ! &
67 : case ("<")
68 0 : out_len = out_len + 4 ! <
69 : case (">")
70 0 : out_len = out_len + 4 ! >
71 : case ('"')
72 1 : out_len = out_len + 6 ! "
73 : case ("'")
74 1 : out_len = out_len + 6 ! '
75 : case default
76 330 : out_len = out_len + 1
77 : end select
78 : end do
79 :
80 : ! Second pass: build escaped string
81 52 : allocate(character(len=out_len) :: escaped)
82 52 : out_len = 0
83 382 : do ii = 1, len(str)
84 382 : select case (str(ii:ii))
85 : case ("&")
86 0 : escaped(out_len + 1:out_len + 5) = "&"
87 0 : out_len = out_len + 5
88 : case ("<")
89 0 : escaped(out_len + 1:out_len + 4) = "<"
90 0 : out_len = out_len + 4
91 : case (">")
92 0 : escaped(out_len + 1:out_len + 4) = ">"
93 0 : out_len = out_len + 4
94 : case ('"')
95 1 : escaped(out_len + 1:out_len + 6) = """
96 1 : out_len = out_len + 6
97 : case ("'")
98 1 : escaped(out_len + 1:out_len + 6) = "'"
99 1 : out_len = out_len + 6
100 : case default
101 328 : out_len = out_len + 1
102 330 : escaped(out_len:out_len) = str(ii:ii)
103 : end select
104 : end do
105 :
106 1263 : end function xml_escape_attrib
107 :
108 : !> Unescape XML entities in a string.
109 3509 : pure function xml_unescape(str) result(unescaped)
110 : character(len=*), intent(in) :: str
111 : character(len=:), allocatable :: unescaped
112 :
113 3509 : integer :: ii, out_len, nn, code_val, ref_len
114 :
115 : ! First pass: compute output length
116 3509 : nn = len(str)
117 3509 : out_len = 0
118 3509 : ii = 1
119 123181 : do while (ii <= nn)
120 119672 : if (str(ii:ii) == "&") then
121 29 : if (ii + 3 <= nn .and. str(ii:ii + 3) == "<") then
122 7 : out_len = out_len + 1
123 7 : ii = ii + 4
124 22 : else if (ii + 3 <= nn .and. str(ii:ii + 3) == ">") then
125 7 : out_len = out_len + 1
126 7 : ii = ii + 4
127 15 : else if (ii + 4 <= nn .and. str(ii:ii + 4) == "&") then
128 7 : out_len = out_len + 1
129 7 : ii = ii + 5
130 8 : else if (ii + 5 <= nn .and. str(ii:ii + 5) == """) then
131 1 : out_len = out_len + 1
132 1 : ii = ii + 6
133 7 : else if (ii + 5 <= nn .and. str(ii:ii + 5) == "'") then
134 1 : out_len = out_len + 1
135 1 : ii = ii + 6
136 6 : else if (ii + 1 <= nn .and. str(ii + 1:ii + 1) == "#") then
137 : ! Numeric character reference: &#NNN; or &#xHH;
138 6 : call parse_char_ref(str, nn, ii, code_val, ref_len)
139 6 : out_len = out_len + 1
140 6 : ii = ii + ref_len
141 : else
142 0 : out_len = out_len + 1
143 0 : ii = ii + 1
144 : end if
145 : else
146 119643 : out_len = out_len + 1
147 119643 : ii = ii + 1
148 : end if
149 : end do
150 :
151 : ! Second pass: build unescaped string
152 3509 : allocate(character(len=out_len) :: unescaped)
153 3509 : out_len = 0
154 3509 : ii = 1
155 123181 : do while (ii <= nn)
156 119672 : if (str(ii:ii) == "&") then
157 29 : if (ii + 3 <= nn .and. str(ii:ii + 3) == "<") then
158 7 : out_len = out_len + 1
159 7 : unescaped(out_len:out_len) = "<"
160 7 : ii = ii + 4
161 22 : else if (ii + 3 <= nn .and. str(ii:ii + 3) == ">") then
162 7 : out_len = out_len + 1
163 7 : unescaped(out_len:out_len) = ">"
164 7 : ii = ii + 4
165 15 : else if (ii + 4 <= nn .and. str(ii:ii + 4) == "&") then
166 7 : out_len = out_len + 1
167 7 : unescaped(out_len:out_len) = "&"
168 7 : ii = ii + 5
169 8 : else if (ii + 5 <= nn .and. str(ii:ii + 5) == """) then
170 1 : out_len = out_len + 1
171 1 : unescaped(out_len:out_len) = '"'
172 1 : ii = ii + 6
173 7 : else if (ii + 5 <= nn .and. str(ii:ii + 5) == "'") then
174 1 : out_len = out_len + 1
175 1 : unescaped(out_len:out_len) = "'"
176 1 : ii = ii + 6
177 6 : else if (ii + 1 <= nn .and. str(ii + 1:ii + 1) == "#") then
178 6 : call parse_char_ref(str, nn, ii, code_val, ref_len)
179 6 : out_len = out_len + 1
180 6 : if (code_val >= 0 .and. code_val <= 255) then
181 6 : unescaped(out_len:out_len) = achar(code_val)
182 : else
183 0 : unescaped(out_len:out_len) = "?" ! Non-representable
184 : end if
185 6 : ii = ii + ref_len
186 : else
187 0 : out_len = out_len + 1
188 0 : unescaped(out_len:out_len) = "&"
189 0 : ii = ii + 1
190 : end if
191 : else
192 119643 : out_len = out_len + 1
193 119643 : unescaped(out_len:out_len) = str(ii:ii)
194 119643 : ii = ii + 1
195 : end if
196 : end do
197 :
198 52 : end function xml_unescape
199 :
200 : !> Parse a numeric character reference at position pos.
201 : !> Handles &#NNN; (decimal) and &#xHH; (hexadecimal).
202 : !> Returns the code point value and total reference length (including & and ;).
203 12 : pure subroutine parse_char_ref(str, str_len, pos, code_val, ref_len)
204 : character(len=*), intent(in) :: str
205 : integer, intent(in) :: str_len, pos
206 : integer, intent(out) :: code_val, ref_len
207 :
208 12 : integer :: jj, digit
209 12 : logical :: is_hex
210 : character(len=1) :: ch
211 :
212 12 : code_val = 0
213 12 : ref_len = 1 ! Fallback: just consume the '&'
214 :
215 : ! pos points to '&', pos+1 should be '#'
216 0 : if (pos + 1 > str_len .or. str(pos + 1:pos + 1) /= "#") return
217 :
218 : ! Check for hex prefix
219 12 : is_hex = .false.
220 12 : jj = pos + 2
221 12 : if (jj <= str_len .and. (str(jj:jj) == "x" .or. str(jj:jj) == "X")) then
222 4 : is_hex = .true.
223 4 : jj = jj + 1
224 : end if
225 :
226 : ! Parse digits until ';'
227 12 : code_val = 0
228 34 : do while (jj <= str_len)
229 34 : ch = str(jj:jj)
230 34 : if (ch == ";") then
231 12 : ref_len = jj - pos + 1
232 12 : return
233 : end if
234 22 : if (is_hex) then
235 8 : digit = hex_digit_value(ch)
236 : else
237 14 : digit = dec_digit_value(ch)
238 : end if
239 22 : if (digit < 0) then
240 : ! Invalid digit: treat & as literal
241 0 : code_val = 0
242 0 : ref_len = 1
243 0 : return
244 : end if
245 22 : if (is_hex) then
246 8 : code_val = code_val * 16 + digit
247 : else
248 14 : code_val = code_val * 10 + digit
249 : end if
250 22 : jj = jj + 1
251 : end do
252 :
253 : ! No semicolon found: treat & as literal
254 0 : code_val = 0
255 0 : ref_len = 1
256 :
257 3521 : end subroutine parse_char_ref
258 :
259 : !> Return decimal digit value, or -1 if not a digit.
260 14 : pure function dec_digit_value(ch) result(val)
261 : character(len=1), intent(in) :: ch
262 : integer :: val
263 :
264 14 : val = iachar(ch) - iachar("0")
265 14 : if (val < 0 .or. val > 9) val = -1
266 :
267 26 : end function dec_digit_value
268 :
269 : !> Return hex digit value (0–15), or -1 if not a hex digit.
270 8 : pure function hex_digit_value(ch) result(val)
271 : character(len=1), intent(in) :: ch
272 : integer :: val
273 :
274 8 : if (ch >= "0" .and. ch <= "9") then
275 6 : val = iachar(ch) - iachar("0")
276 2 : else if (ch >= "a" .and. ch <= "f") then
277 0 : val = iachar(ch) - iachar("a") + 10
278 2 : else if (ch >= "A" .and. ch <= "F") then
279 2 : val = iachar(ch) - iachar("A") + 10
280 : else
281 0 : val = -1
282 : end if
283 :
284 22 : end function hex_digit_value
285 :
286 : end module hsd_data_xml_escape
|
