line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# |
2
|
|
|
|
|
|
|
# Web::DataService::JSON |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# This module is responsible for putting data responses into JSON format. |
5
|
|
|
|
|
|
|
# |
6
|
|
|
|
|
|
|
# Author: Michael McClennen |
7
|
|
|
|
|
|
|
|
8
|
1
|
|
|
1
|
|
7
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
41
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
package Web::DataService::Plugin::JSON; |
11
|
|
|
|
|
|
|
|
12
|
1
|
|
|
1
|
|
6
|
use JSON; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
6
|
|
13
|
1
|
|
|
1
|
|
131
|
use Encode; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
95
|
|
14
|
1
|
|
|
1
|
|
46
|
use Scalar::Util qw(reftype); |
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
69
|
|
15
|
1
|
|
|
1
|
|
7
|
use Carp qw(croak); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
42
|
|
16
|
|
|
|
|
|
|
|
17
|
1
|
|
|
1
|
|
6
|
use parent 'Exporter'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
7
|
|
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our @EXPORT_OK = qw(json_list_value json_clean); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
# emit_header ( request, field_list ) |
23
|
|
|
|
|
|
|
# |
24
|
|
|
|
|
|
|
# Return the initial text of a JSON result. |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
sub emit_header { |
27
|
|
|
|
|
|
|
|
28
|
0
|
|
|
0
|
0
|
|
my ($class, $request, $field_list) = @_; |
29
|
|
|
|
|
|
|
|
30
|
0
|
|
|
|
|
|
my $output = '{' . "\n"; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
# Check if we have been asked to report the data source and parameters. |
33
|
|
|
|
|
|
|
|
34
|
0
|
0
|
|
|
|
|
if ( $request->display_datainfo ) |
35
|
|
|
|
|
|
|
{ |
36
|
0
|
|
|
|
|
|
my $info = $request->datainfo; |
37
|
|
|
|
|
|
|
|
38
|
0
|
|
|
|
|
|
foreach my $key ( $request->datainfo_keys ) |
39
|
|
|
|
|
|
|
{ |
40
|
0
|
0
|
|
|
|
|
next unless $info->{$key}; |
41
|
0
|
|
|
|
|
|
my $value = json_clean($info->{$key}); |
42
|
|
|
|
|
|
|
|
43
|
0
|
|
|
|
|
|
$output .= qq{"$key":$value,\n}; |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
0
|
|
|
|
|
|
$output .= '"parameters":{' . "\n"; |
47
|
|
|
|
|
|
|
|
48
|
0
|
|
|
|
|
|
my @display = $request->params_for_display; |
49
|
0
|
|
|
|
|
|
my $sep = ''; |
50
|
|
|
|
|
|
|
|
51
|
0
|
|
|
|
|
|
while ( @display ) |
52
|
|
|
|
|
|
|
{ |
53
|
0
|
|
|
|
|
|
my $param = shift @display; |
54
|
0
|
|
|
|
|
|
my $value = shift @display; |
55
|
|
|
|
|
|
|
|
56
|
0
|
0
|
0
|
|
|
|
next unless defined $param && $param ne ''; |
57
|
0
|
|
0
|
|
|
|
$value //= ''; |
58
|
|
|
|
|
|
|
|
59
|
0
|
|
|
|
|
|
$output .= $sep; $sep = ",\n"; |
|
0
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
|
61
|
0
|
0
|
|
|
|
|
if ( ref $value eq 'ARRAY' ) |
62
|
|
|
|
|
|
|
{ |
63
|
0
|
|
|
|
|
|
$output .= json_list_value($param, @$value); |
64
|
|
|
|
|
|
|
} |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
else |
67
|
|
|
|
|
|
|
{ |
68
|
0
|
|
|
|
|
|
$value = json_clean($value); |
69
|
0
|
|
|
|
|
|
$output .= qq<"$param":$value>; |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
0
|
|
|
|
|
|
$output .= "\n},\n"; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
# If there have been any extra datainfo fields set, list them now. |
76
|
|
|
|
|
|
|
|
77
|
0
|
0
|
|
|
|
|
if ( my @extra = $request->extra_datainfo_keys ) |
78
|
|
|
|
|
|
|
{ |
79
|
0
|
|
|
|
|
|
foreach my $key ( @extra ) |
80
|
|
|
|
|
|
|
{ |
81
|
0
|
0
|
|
|
|
|
next unless defined $key; |
82
|
0
|
|
|
|
|
|
my $value = $request->extra_datainfo($key); |
83
|
0
|
0
|
|
|
|
|
next unless defined $value; |
84
|
|
|
|
|
|
|
|
85
|
0
|
|
|
|
|
|
$output .= $sep; $sep = ",\n"; |
|
0
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
0
|
0
|
0
|
|
|
|
if ( ref $value && reftype $value eq 'HASH' ) |
|
|
0
|
0
|
|
|
|
|
88
|
|
|
|
|
|
|
{ |
89
|
|
|
|
|
|
|
# not implemented yet |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
elsif ( ref $value && reftype $value eq 'ARRAY' ) |
93
|
|
|
|
|
|
|
{ |
94
|
0
|
|
|
|
|
|
$value = $class->emit_array($request, $value); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
else |
98
|
|
|
|
|
|
|
{ |
99
|
0
|
|
|
|
|
|
$value = json_clean($value); |
100
|
|
|
|
|
|
|
} |
101
|
|
|
|
|
|
|
|
102
|
0
|
|
|
|
|
|
$output .= qq<"$key":$value,\n>; |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# Check if we have been asked to report the result count, and if it is |
108
|
|
|
|
|
|
|
# available. |
109
|
|
|
|
|
|
|
|
110
|
0
|
|
|
|
|
|
$output .= '"elapsed_time":' . sprintf("%.3g", $request->{elapsed}) . ",\n"; |
111
|
|
|
|
|
|
|
|
112
|
0
|
0
|
|
|
|
|
if ( $request->display_counts ) |
113
|
|
|
|
|
|
|
{ |
114
|
0
|
|
|
|
|
|
my $counts = $request->result_counts; |
115
|
|
|
|
|
|
|
|
116
|
0
|
|
0
|
|
|
|
$output .= '"records_found":' . json_clean($counts->{found} || '0') . ",\n"; |
117
|
0
|
|
0
|
|
|
|
$output .= '"records_returned":' . json_clean($counts->{returned} || '0') . ",\n"; |
118
|
|
|
|
|
|
|
$output .= '"record_offset":' . json_clean($counts->{offset}) . ",\n" |
119
|
0
|
0
|
0
|
|
|
|
if defined $counts->{offset} && $counts->{offset} > 0; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
# Check if we have any warning messages to convey |
123
|
|
|
|
|
|
|
|
124
|
0
|
0
|
|
|
|
|
if ( my @msgs = $request->warnings ) |
125
|
|
|
|
|
|
|
{ |
126
|
0
|
|
|
|
|
|
$output .= qq<"warnings":[\n>; |
127
|
0
|
|
|
|
|
|
my $sep = ''; |
128
|
0
|
|
|
|
|
|
foreach my $m (@msgs) |
129
|
|
|
|
|
|
|
{ |
130
|
0
|
|
|
|
|
|
$output .= $sep; $sep = ",\n"; |
|
0
|
|
|
|
|
|
|
131
|
0
|
|
|
|
|
|
$output .= json_clean($m); |
132
|
|
|
|
|
|
|
} |
133
|
0
|
|
|
|
|
|
$output .= qq<\n],\n>; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Check if we have summary data to output. |
137
|
|
|
|
|
|
|
|
138
|
0
|
0
|
0
|
|
|
|
if ( $request->{summary_data} && $request->{summary_field_list} ) |
139
|
|
|
|
|
|
|
{ |
140
|
0
|
|
|
|
|
|
$output .= qq<"summary": >; |
141
|
0
|
|
0
|
|
|
|
$output .= $class->emit_object($request, $request->{summary_data}, $request->{summary_field_list}) || '""'; |
142
|
0
|
|
|
|
|
|
$output .= ",\n"; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# The actual data will go into an array, in a field called "records". |
146
|
|
|
|
|
|
|
|
147
|
0
|
|
|
|
|
|
$output .= qq<"records": [\n>; |
148
|
0
|
|
|
|
|
|
return $output; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
# emit_separator ( ) |
153
|
|
|
|
|
|
|
# |
154
|
|
|
|
|
|
|
# Return the record separator string. This will be output between each |
155
|
|
|
|
|
|
|
# record, but not before the first one. |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub emit_separator { |
158
|
|
|
|
|
|
|
|
159
|
0
|
|
|
0
|
0
|
|
return ",\n"; |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# emit_empty ( ) |
164
|
|
|
|
|
|
|
# |
165
|
|
|
|
|
|
|
# Return the string (if any) to output in lieu of an empty result set. |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub emit_empty { |
168
|
|
|
|
|
|
|
|
169
|
0
|
|
|
0
|
0
|
|
my ($class, $request) = @_; |
170
|
|
|
|
|
|
|
|
171
|
0
|
|
|
|
|
|
return ''; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
# emit_footer ( ) |
176
|
|
|
|
|
|
|
# |
177
|
|
|
|
|
|
|
# Return the final text for a JSON result. |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
sub emit_footer { |
180
|
|
|
|
|
|
|
|
181
|
0
|
|
|
0
|
0
|
|
my ($class, $request) = @_; |
182
|
|
|
|
|
|
|
|
183
|
0
|
|
|
|
|
|
return qq<\n]\n}\n>; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
# emit_error ( code, errors, warnings ) |
188
|
|
|
|
|
|
|
# |
189
|
|
|
|
|
|
|
# Return the formatted output for an error message body in JSON. |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
sub emit_error { |
192
|
|
|
|
|
|
|
|
193
|
0
|
|
|
0
|
0
|
|
my ($class, $code, $errors, $warnings, $cautions) = @_; |
194
|
|
|
|
|
|
|
|
195
|
0
|
0
|
|
|
|
|
unless ( ref $errors eq 'ARRAY' ) |
196
|
|
|
|
|
|
|
{ |
197
|
0
|
|
|
|
|
|
$errors = [ "bad call to 'emit_error'" ]; |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
0
|
0
|
0
|
|
|
|
if ( defined $warnings && ! ref $warnings eq 'ARRAY' ) |
201
|
|
|
|
|
|
|
{ |
202
|
0
|
|
|
|
|
|
$warnings = [ "bad call to 'emit_error'" ]; |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
0
|
|
|
|
|
|
my $error = '"status_code": ' . $code; |
206
|
0
|
0
|
0
|
|
|
|
$error .= ",\n" . json_list_value("errors", @$errors) if ref $errors eq 'ARRAY' && @$errors; |
207
|
0
|
0
|
0
|
|
|
|
$error .= ",\n" . json_list_value("cautions", @$cautions) if ref $cautions eq 'ARRAY' && @$cautions; |
208
|
0
|
0
|
0
|
|
|
|
$error .= ",\n" . json_list_value("warnings", @$warnings) if ref $warnings eq 'ARRAY' && @$warnings; |
209
|
|
|
|
|
|
|
|
210
|
0
|
|
|
|
|
|
return "{ $error }\n"; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
# emit_record ( request, record, field_list ) |
215
|
|
|
|
|
|
|
# |
216
|
|
|
|
|
|
|
# Return the formatted output for a single record in JSON according to the |
217
|
|
|
|
|
|
|
# specified field list. |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
sub emit_record { |
220
|
|
|
|
|
|
|
|
221
|
0
|
|
|
0
|
0
|
|
my ($class, $request, $record, $field_list) = @_; |
222
|
|
|
|
|
|
|
|
223
|
0
|
|
|
|
|
|
return $class->emit_object($request, $record, $field_list); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
# emit_object ( request, record, field_list ) |
228
|
|
|
|
|
|
|
# |
229
|
|
|
|
|
|
|
# Generate text that expresses the given record in JSON according to the given |
230
|
|
|
|
|
|
|
# list of output field specifications. |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
sub emit_object { |
233
|
|
|
|
|
|
|
|
234
|
0
|
|
|
0
|
0
|
|
my ($class, $request, $record, $field_list) = @_; |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
# Start with an empty string. |
237
|
|
|
|
|
|
|
|
238
|
0
|
|
|
|
|
|
my $outrec = '{'; |
239
|
0
|
|
|
|
|
|
my $sep = ''; |
240
|
|
|
|
|
|
|
|
241
|
|
|
|
|
|
|
# Go through the rule list, generating the fields one by one. $field_list |
242
|
|
|
|
|
|
|
# may be either an array of rule records or a single one. |
243
|
|
|
|
|
|
|
|
244
|
0
|
0
|
0
|
|
|
|
foreach my $f (reftype $field_list && reftype $field_list eq 'ARRAY' ? @$field_list : $field_list) |
245
|
|
|
|
|
|
|
{ |
246
|
|
|
|
|
|
|
# Skip any field that is empty, unless 'always' or 'value' is set. |
247
|
|
|
|
|
|
|
|
248
|
0
|
|
|
|
|
|
my $field = $f->{field}; |
249
|
0
|
|
|
|
|
|
my $data_type = $f->{data_type}; |
250
|
|
|
|
|
|
|
|
251
|
|
|
|
|
|
|
next unless $f->{always} or defined $f->{value} or |
252
|
0
|
0
|
0
|
|
|
|
defined $record->{$field} and $record->{$field} ne ''; |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# Skip any field with a 'dedup' attribute if its value is the same as |
255
|
|
|
|
|
|
|
# the value of the field indicated by the attribute. |
256
|
|
|
|
|
|
|
|
257
|
|
|
|
|
|
|
next if $f->{dedup} and defined $record->{$field} and defined $record->{$f->{dedup}} |
258
|
0
|
0
|
0
|
|
|
|
and $record->{$field} eq $record->{$f->{dedup}}; |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
# Skip any field with a 'if_field' attribute if the corresponding |
261
|
|
|
|
|
|
|
# field does not have a true value. |
262
|
|
|
|
|
|
|
|
263
|
0
|
0
|
0
|
|
|
|
next if $f->{if_field} and not $record->{$f->{if_field}}; |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
# Skip any field with a 'not_field' attribute if the corresponding |
266
|
|
|
|
|
|
|
# field has a true value. |
267
|
|
|
|
|
|
|
|
268
|
0
|
0
|
0
|
|
|
|
next if $f->{not_field} and $record->{$f->{not_field}}; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
# Start with the initial value for this field. If it contains a |
271
|
|
|
|
|
|
|
# 'value' attribute, use that. Otherwise, use the indicated field |
272
|
|
|
|
|
|
|
# value from the current record. If that is not defined, use the |
273
|
|
|
|
|
|
|
# empty string. |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
my $value = defined $f->{value} ? $f->{value} |
276
|
0
|
0
|
|
|
|
|
: defined $record->{$field} ? $record->{$field} |
|
|
0
|
|
|
|
|
|
277
|
|
|
|
|
|
|
: ''; |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
# If the field has a 'sub_record' attribute and the value is a hashref then |
280
|
|
|
|
|
|
|
# generate output to represent a sub-object by applying the named |
281
|
|
|
|
|
|
|
# output section to the value. If the value is a scalar then this |
282
|
|
|
|
|
|
|
# field is silently ignored. |
283
|
|
|
|
|
|
|
|
284
|
0
|
0
|
|
|
|
|
if ( defined $f->{sub_record} ) |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
285
|
|
|
|
|
|
|
{ |
286
|
0
|
|
|
|
|
|
my $ds = $request->ds; |
287
|
0
|
|
|
|
|
|
$ds->configure_block($request, $f->{sub_record}); |
288
|
|
|
|
|
|
|
|
289
|
0
|
|
|
|
|
|
my $output_list = $request->{block_field_list}{$f->{sub_record}}; |
290
|
0
|
|
|
|
|
|
my $proc_list = $request->{block_proc_list}{$f->{sub_record}}; |
291
|
|
|
|
|
|
|
|
292
|
0
|
0
|
0
|
|
|
|
if ( ref $value && reftype $value eq 'HASH' ) |
|
|
0
|
0
|
|
|
|
|
293
|
|
|
|
|
|
|
{ |
294
|
0
|
0
|
0
|
|
|
|
$request->_process_record($value, $proc_list) if $proc_list && @$proc_list; |
295
|
|
|
|
|
|
|
|
296
|
0
|
0
|
0
|
|
|
|
if ( $output_list && @$output_list ) |
297
|
|
|
|
|
|
|
{ |
298
|
0
|
|
|
|
|
|
$value = $class->emit_object($request, $value, $output_list); |
299
|
|
|
|
|
|
|
} |
300
|
|
|
|
|
|
|
else |
301
|
|
|
|
|
|
|
{ |
302
|
0
|
|
|
|
|
|
$value = json_clean($value, $data_type); |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# If instead the value is an arrayref then apply the rule to each item |
307
|
|
|
|
|
|
|
# in the list. |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
elsif ( ref $value && reftype $value eq 'ARRAY' ) |
310
|
|
|
|
|
|
|
{ |
311
|
0
|
0
|
0
|
|
|
|
if ( $proc_list && @$proc_list ) |
312
|
|
|
|
|
|
|
{ |
313
|
0
|
|
|
|
|
|
foreach my $v ( @$value ) |
314
|
|
|
|
|
|
|
{ |
315
|
0
|
0
|
|
|
|
|
$request->_process_record($v, $proc_list) if $proc_list; |
316
|
|
|
|
|
|
|
} |
317
|
|
|
|
|
|
|
} |
318
|
|
|
|
|
|
|
|
319
|
0
|
0
|
0
|
|
|
|
if ( $output_list && @$output_list ) |
320
|
|
|
|
|
|
|
{ |
321
|
0
|
|
|
|
|
|
$value = $class->emit_array($request, $value, $output_list); |
322
|
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
|
else |
324
|
|
|
|
|
|
|
{ |
325
|
0
|
|
|
|
|
|
$value = json_clean($value, $data_type); |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
else |
330
|
|
|
|
|
|
|
{ |
331
|
0
|
|
|
|
|
|
$value = json_clean($value, $data_type); |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
# Otherwise, if the value is an arrayref then we generate output for |
336
|
|
|
|
|
|
|
# an array. If the field is marked "show_as_list", then do this even |
337
|
|
|
|
|
|
|
# if there is only one value. |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
elsif ( ref $value eq 'ARRAY' ) |
340
|
|
|
|
|
|
|
{ |
341
|
0
|
|
|
|
|
|
$value = $class->emit_array($request, $value); |
342
|
|
|
|
|
|
|
} |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
elsif ( $f->{show_as_list} ) |
345
|
|
|
|
|
|
|
{ |
346
|
0
|
|
|
|
|
|
$value = $class->emit_array($request, [ $value ]); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
# Otherwise just use the value. |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
else |
352
|
|
|
|
|
|
|
{ |
353
|
0
|
|
|
|
|
|
$value = json_clean($value, $data_type); |
354
|
|
|
|
|
|
|
} |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# Now, add the value to the growing output. Add a comma before each |
357
|
|
|
|
|
|
|
# record except the first. |
358
|
|
|
|
|
|
|
|
359
|
0
|
|
|
|
|
|
my $outkey = $f->{name}; |
360
|
|
|
|
|
|
|
|
361
|
0
|
|
|
|
|
|
$outrec .= qq<$sep"$outkey":$value>; |
362
|
0
|
|
|
|
|
|
$sep = q<,>; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
# If this record has hierarchical children, process them now. (Do we |
366
|
|
|
|
|
|
|
# still need this?) |
367
|
|
|
|
|
|
|
|
368
|
0
|
0
|
|
|
|
|
if ( exists $record->{hier_child} ) |
369
|
|
|
|
|
|
|
{ |
370
|
0
|
|
|
|
|
|
my $children = $class->emit_array($record->{hier_child}, $field_list); |
371
|
0
|
|
|
|
|
|
$outrec .= qq<,"children":$children>; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
# Now finish the output string and return it. |
375
|
|
|
|
|
|
|
|
376
|
0
|
|
|
|
|
|
$outrec .= '}'; |
377
|
|
|
|
|
|
|
|
378
|
0
|
|
|
|
|
|
return $outrec; |
379
|
|
|
|
|
|
|
} |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
# emit_array ( request, arrayref, field_list ) |
383
|
|
|
|
|
|
|
# |
384
|
|
|
|
|
|
|
# Generate text that expresses the given array of values in JSON according to |
385
|
|
|
|
|
|
|
# the given list of field specifications. |
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
sub emit_array { |
388
|
|
|
|
|
|
|
|
389
|
0
|
|
|
0
|
0
|
|
my ($class, $request, $arrayref, $field_list) = @_; |
390
|
|
|
|
|
|
|
|
391
|
0
|
0
|
0
|
|
|
|
my $f = $field_list if reftype $field_list && reftype $field_list ne 'ARRAY'; |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# Start with an empty string. |
394
|
|
|
|
|
|
|
|
395
|
0
|
|
|
|
|
|
my $outrec = '['; |
396
|
0
|
|
|
|
|
|
my $sep = ''; |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# Go through the elements of the specified arrayref, applying the |
399
|
|
|
|
|
|
|
# specified rule to each one. |
400
|
|
|
|
|
|
|
|
401
|
0
|
|
|
|
|
|
my $value = ''; |
402
|
|
|
|
|
|
|
|
403
|
0
|
|
|
|
|
|
foreach my $elt ( @$arrayref ) |
404
|
|
|
|
|
|
|
{ |
405
|
0
|
0
|
0
|
|
|
|
if ( reftype $elt && reftype $elt eq 'ARRAY' ) |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
406
|
|
|
|
|
|
|
{ |
407
|
0
|
|
|
|
|
|
$value = $class->emit_array($request, $elt, $field_list); |
408
|
|
|
|
|
|
|
} |
409
|
|
|
|
|
|
|
|
410
|
|
|
|
|
|
|
elsif ( reftype $elt && reftype $elt eq 'HASH' ) |
411
|
|
|
|
|
|
|
{ |
412
|
0
|
0
|
|
|
|
|
next unless $field_list; |
413
|
0
|
|
|
|
|
|
$value = $class->emit_object($request, $elt, $field_list); |
414
|
|
|
|
|
|
|
} |
415
|
|
|
|
|
|
|
|
416
|
|
|
|
|
|
|
elsif ( ref $elt ) |
417
|
|
|
|
|
|
|
{ |
418
|
0
|
|
|
|
|
|
next; |
419
|
|
|
|
|
|
|
} |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
else |
422
|
|
|
|
|
|
|
{ |
423
|
0
|
|
|
|
|
|
$value = json_clean($elt); |
424
|
|
|
|
|
|
|
} |
425
|
|
|
|
|
|
|
|
426
|
0
|
0
|
0
|
|
|
|
if ( defined $value and $value ne '' ) |
427
|
|
|
|
|
|
|
{ |
428
|
0
|
|
|
|
|
|
$outrec .= "$sep$value"; |
429
|
0
|
|
|
|
|
|
$sep = ','; |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
|
433
|
0
|
|
|
|
|
|
$outrec .= ']'; |
434
|
|
|
|
|
|
|
|
435
|
0
|
|
|
|
|
|
return $outrec; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
|
439
|
|
|
|
|
|
|
# json_list_value ( key, @values ) |
440
|
|
|
|
|
|
|
# |
441
|
|
|
|
|
|
|
# Return a string representing a JSON key with a list of values. This is used |
442
|
|
|
|
|
|
|
# for generating error and warning keys. |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
sub json_list_value { |
445
|
|
|
|
|
|
|
|
446
|
0
|
|
|
0
|
0
|
|
my ($key, @values) = @_; |
447
|
|
|
|
|
|
|
|
448
|
0
|
|
|
|
|
|
my $output = qq<"$key": [>; |
449
|
0
|
|
|
|
|
|
my $sep = ''; |
450
|
|
|
|
|
|
|
|
451
|
0
|
|
|
|
|
|
foreach my $m (@values) |
452
|
|
|
|
|
|
|
{ |
453
|
0
|
|
|
|
|
|
$output .= $sep; $sep = ', '; |
|
0
|
|
|
|
|
|
|
454
|
0
|
|
|
|
|
|
$output .= json_clean($m); |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
0
|
|
|
|
|
|
$output .= qq<]>; |
458
|
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
# json_clean ( string ) |
462
|
|
|
|
|
|
|
# |
463
|
|
|
|
|
|
|
# Given a string value, return an equivalent string value that will be valid |
464
|
|
|
|
|
|
|
# as part of a JSON result. |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
my (%ESCAPE) = ( '\\' => '\\\\', '"' => '\\"', "\t" => '\\t', "\n" => '\\n', |
467
|
|
|
|
|
|
|
"\r" => '\\r' ); #' |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
sub json_clean { |
470
|
|
|
|
|
|
|
|
471
|
0
|
|
|
0
|
0
|
|
my ($string, $data_type) = @_; |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
# Return an empty string unless the value is defined. |
474
|
|
|
|
|
|
|
|
475
|
0
|
0
|
0
|
|
|
|
return '""' unless defined $string and $string ne ''; |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
# Do a quick check for numbers. If it matches, return the value as-is |
478
|
|
|
|
|
|
|
# unless the data_type is 'str'. In that case, the field value is |
479
|
|
|
|
|
|
|
# intended to be a string so we should quote it even if it looks like a number. |
480
|
|
|
|
|
|
|
|
481
|
0
|
0
|
0
|
|
|
|
return $string if $string =~ qr{ ^ -? (?: [1-9][0-9]* | 0 ) (?: \. [0-9]+ )? (?: [Ee] -? [0-9]+ )? $ }x |
|
|
|
0
|
|
|
|
|
482
|
|
|
|
|
|
|
and not (defined $data_type && $data_type eq 'str'); |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# Do another quick check for okay characters. If there's nothing exotic, |
485
|
|
|
|
|
|
|
# just return the quoted value. |
486
|
|
|
|
|
|
|
|
487
|
0
|
0
|
|
|
|
|
return '"' . $string . '"' unless $string =~ /[^a-zA-Z0-9 _.,;:<>-]/; |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
# Otherwise, we need to do some longer processing. |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
# Turn any numeric character references into actual Unicode characters. |
492
|
|
|
|
|
|
|
# The database does contain some of these. |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
# WARNING: this decoding needs to be checked. $$$ |
495
|
|
|
|
|
|
|
|
496
|
0
|
|
|
|
|
|
$string =~ s/&\#(\d)+;/decode_utf8(pack("U", $1))/eg; |
|
0
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
# Next, escape all backslashes, double-quotes and whitespace control characters |
499
|
|
|
|
|
|
|
|
500
|
0
|
|
|
|
|
|
$string =~ s/(\\|\"|\n|\t|\r)/$ESCAPE{$1}/ge; |
|
0
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
# Finally, delete all other control characters (they shouldn't be in the |
503
|
|
|
|
|
|
|
# database in the first place, but unfortunately some rows do contain |
504
|
|
|
|
|
|
|
# them). |
505
|
|
|
|
|
|
|
|
506
|
0
|
|
|
|
|
|
$string =~ s/[\0-\037\177]//g; |
507
|
|
|
|
|
|
|
|
508
|
0
|
|
|
|
|
|
return '"' . $string . '"'; |
509
|
|
|
|
|
|
|
} |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
1; |