File Coverage

lib/Web/DataService/Plugin/JSON.pm
Criterion Covered Total %
statement 18 151 11.9
branch 0 80 0.0
condition 0 95 0.0
subroutine 6 16 37.5
pod 0 10 0.0
total 24 352 6.8


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