Line data Source code
1 : !> JSON string escaping and unescaping utilities.
2 : !>
3 : !> Handles the JSON spec (RFC 8259) required escapes:
4 : !> - Backslash sequences: \", \\, \/, \b, \f, \n, \r, \t
5 : !> - Control characters (U+0000–U+001F) as \uXXXX
6 : module hsd_data_json_escape
7 : use, intrinsic :: iso_fortran_env, only: error_unit
8 : implicit none(type, external)
9 : private
10 :
11 : public :: json_escape_string, json_unescape_string
12 :
13 : contains
14 :
15 : !> Escape a Fortran string for use as a JSON string value.
16 : !> Does NOT add surrounding quotes.
17 1135 : pure function json_escape_string(str) result(escaped)
18 : character(len=*), intent(in) :: str
19 : character(len=:), allocatable :: escaped
20 :
21 1135 : integer :: ii, ic, out_len
22 : character(len=6) :: hex_buf
23 :
24 : ! First pass: compute output length
25 1135 : out_len = 0
26 670541 : do ii = 1, len(str)
27 669406 : ic = iachar(str(ii:ii))
28 1135 : select case (ic)
29 : case (8) ! backspace
30 0 : out_len = out_len + 2
31 : case (9) ! tab
32 1 : out_len = out_len + 2
33 : case (10) ! newline
34 41 : out_len = out_len + 2
35 : case (12) ! form feed
36 0 : out_len = out_len + 2
37 : case (13) ! carriage return
38 0 : out_len = out_len + 2
39 : case (34) ! double quote
40 3 : out_len = out_len + 2
41 : case (92) ! backslash
42 15 : out_len = out_len + 2
43 : case (0:7, 11, 14:31) ! other control characters
44 0 : out_len = out_len + 6 ! \uXXXX
45 : case default
46 669406 : out_len = out_len + 1
47 : end select
48 : end do
49 :
50 1135 : allocate(character(len=out_len) :: escaped)
51 :
52 : ! Second pass: build escaped string
53 1135 : out_len = 0
54 670541 : do ii = 1, len(str)
55 669406 : ic = iachar(str(ii:ii))
56 1135 : select case (ic)
57 : case (8) ! backspace → \b
58 0 : escaped(out_len + 1:out_len + 2) = "\b"
59 0 : out_len = out_len + 2
60 : case (9) ! tab → \t
61 1 : escaped(out_len + 1:out_len + 2) = "\t"
62 1 : out_len = out_len + 2
63 : case (10) ! newline → \n
64 41 : escaped(out_len + 1:out_len + 2) = "\n"
65 41 : out_len = out_len + 2
66 : case (12) ! form feed → \f
67 0 : escaped(out_len + 1:out_len + 2) = "\f"
68 0 : out_len = out_len + 2
69 : case (13) ! carriage return → \r
70 0 : escaped(out_len + 1:out_len + 2) = "\r"
71 0 : out_len = out_len + 2
72 : case (34) ! quote → \"
73 3 : escaped(out_len + 1:out_len + 2) = '\"'
74 3 : out_len = out_len + 2
75 : case (92) ! backslash char
76 15 : escaped(out_len + 1:out_len + 2) = "\\"
77 15 : out_len = out_len + 2
78 : case (0:7, 11, 14:31) ! control → \u00XX
79 0 : write(hex_buf, "(a2,z4.4)") "\u", ic
80 0 : escaped(out_len + 1:out_len + 6) = hex_buf
81 0 : out_len = out_len + 6
82 : case default
83 669346 : out_len = out_len + 1
84 669406 : escaped(out_len:out_len) = str(ii:ii)
85 : end select
86 : end do
87 :
88 2270 : end function json_escape_string
89 :
90 : !> Unescape a JSON string value.
91 : !> Input should NOT include surrounding quotes.
92 : !> Code points 0-255 are mapped via achar(); code points > 255 are replaced
93 : !> with '?' and a warning is written to stderr.
94 2317 : function json_unescape_string(str) result(unescaped)
95 : character(len=*), intent(in) :: str
96 : character(len=:), allocatable :: unescaped
97 :
98 2317 : integer :: ii, nn, out_len, code
99 : character(len=4) :: hex_str
100 :
101 2317 : nn = len(str)
102 :
103 : ! First pass: compute output length
104 2317 : out_len = 0
105 2317 : ii = 1
106 682322 : do while (ii <= nn)
107 680005 : if (str(ii:ii) == "\" .and. ii + 1 <= nn) then
108 187 : select case (str(ii + 1:ii + 1))
109 : case ('"', "\", "/", "b", "f", "n", "r", "t")
110 90 : out_len = out_len + 1
111 90 : ii = ii + 2
112 : case ("u")
113 14 : if (ii + 5 <= nn) then
114 7 : out_len = out_len + 1 ! one char for any code point
115 7 : ii = ii + 6
116 : else
117 0 : out_len = out_len + 1
118 0 : ii = ii + 1
119 : end if
120 : case default
121 0 : out_len = out_len + 1
122 97 : ii = ii + 1
123 : end select
124 : else
125 679908 : out_len = out_len + 1
126 679908 : ii = ii + 1
127 : end if
128 : end do
129 :
130 2317 : allocate(character(len=out_len) :: unescaped)
131 :
132 : ! Second pass: build unescaped string
133 2317 : out_len = 0
134 2317 : ii = 1
135 682322 : do while (ii <= nn)
136 680005 : if (str(ii:ii) == "\" .and. ii + 1 <= nn) then
137 100 : select case (str(ii + 1:ii + 1))
138 : case ('"')
139 3 : out_len = out_len + 1
140 3 : unescaped(out_len:out_len) = '"'
141 3 : ii = ii + 2
142 : case ("\")
143 15 : out_len = out_len + 1
144 15 : unescaped(out_len:out_len) = "\"
145 15 : ii = ii + 2
146 : case ("/")
147 0 : out_len = out_len + 1
148 0 : unescaped(out_len:out_len) = "/"
149 0 : ii = ii + 2
150 : case ("b")
151 0 : out_len = out_len + 1
152 0 : unescaped(out_len:out_len) = char(8)
153 0 : ii = ii + 2
154 : case ("f")
155 0 : out_len = out_len + 1
156 0 : unescaped(out_len:out_len) = char(12)
157 0 : ii = ii + 2
158 : case ("n")
159 72 : out_len = out_len + 1
160 72 : unescaped(out_len:out_len) = char(10)
161 72 : ii = ii + 2
162 : case ("r")
163 0 : out_len = out_len + 1
164 0 : unescaped(out_len:out_len) = char(13)
165 0 : ii = ii + 2
166 : case ("t")
167 0 : out_len = out_len + 1
168 0 : unescaped(out_len:out_len) = char(9)
169 0 : ii = ii + 2
170 : case ("u")
171 14 : if (ii + 5 <= nn) then
172 7 : hex_str = str(ii + 2:ii + 5)
173 7 : code = hex_to_int(hex_str)
174 7 : out_len = out_len + 1
175 7 : if (code >= 0 .and. code <= 255) then
176 5 : unescaped(out_len:out_len) = char(code)
177 : else
178 2 : unescaped(out_len:out_len) = "?"
179 2 : write(error_unit, "(a,a,a)") "Warning: non-representable \u escape: \u", &
180 4 : & hex_str, " replaced with '?'"
181 : end if
182 7 : ii = ii + 6
183 : else
184 0 : out_len = out_len + 1
185 0 : unescaped(out_len:out_len) = str(ii:ii)
186 0 : ii = ii + 1
187 : end if
188 : case default
189 0 : out_len = out_len + 1
190 0 : unescaped(out_len:out_len) = str(ii:ii)
191 97 : ii = ii + 1
192 : end select
193 : else
194 679908 : out_len = out_len + 1
195 679908 : unescaped(out_len:out_len) = str(ii:ii)
196 679908 : ii = ii + 1
197 : end if
198 : end do
199 :
200 1135 : end function json_unescape_string
201 :
202 : !> Convert a 4-character hex string to integer (pure).
203 7 : pure function hex_to_int(hex) result(val)
204 : character(len=4), intent(in) :: hex
205 : integer :: val
206 :
207 7 : integer :: ii, digit
208 :
209 7 : val = 0
210 35 : do ii = 1, 4
211 28 : val = val * 16
212 28 : select case (hex(ii:ii))
213 : case ("0":"9")
214 25 : digit = iachar(hex(ii:ii)) - iachar("0")
215 : case ("a":"f")
216 0 : digit = iachar(hex(ii:ii)) - iachar("a") + 10
217 : case ("A":"F")
218 3 : digit = iachar(hex(ii:ii)) - iachar("A") + 10
219 : case default
220 28 : digit = 0
221 : end select
222 35 : val = val + digit
223 : end do
224 :
225 2324 : end function hex_to_int
226 :
227 : end module hsd_data_json_escape
|
