File Coverage

lib/Web/DataService/Plugin/Text.pm
Criterion Covered Total %
statement 12 105 11.4
branch 0 46 0.0
condition 0 34 0.0
subroutine 4 12 33.3
pod 0 8 0.0
total 16 205 7.8


line stmt bran cond sub pod time code
1             #
2             # Web::DataService::Text
3             #
4             # This module is responsible for putting data responses into either
5             # tab-separated text or comma-separated text format. It is used when
6             # the user selects any of the following three format strings:
7             #
8             # csv comma-separated text
9             # tsv tab-separated text
10             # txt comma-separated text, to be shown directly in a browser tab
11             #
12             # Author: Michael McClennen
13              
14 1     1   7 use strict;
  1         3  
  1         44  
15              
16             package Web::DataService::Plugin::Text;
17              
18 1     1   25 use Encode;
  1         2  
  1         75  
19 1     1   6 use Scalar::Util qw(reftype);
  1         2  
  1         41  
20 1     1   6 use Carp qw(croak);
  1         2  
  1         1367  
21              
22              
23              
24             # emit_header ( request, field_list )
25             #
26             # Generate any initial text that is necessary for a text format response. This
27             # will be formatted according to the format suffix specified in the request
28             # (comma-separated or tab-separated).
29              
30             sub emit_header {
31              
32 0     0 0   my ($class, $request, $field_list) = @_;
33            
34 0           my $output = '';
35            
36             # If the user has directed that the header be suppressed, just return
37             # the empty string.
38            
39 0 0         return $output unless $request->display_header;
40            
41             # If the user has specified that the source of this data be shown, add
42             # some header lines to convey this.
43            
44 0 0         if ( $request->display_datainfo )
45             {
46 0           my $info = $request->data_info;
47            
48 0           foreach my $key ( $request->data_info_keys )
49             {
50 0 0         next unless $info->{$key};
51 0           my $label = generate_label($key);
52 0           $output .= $class->emit_line($request, $label, $info->{$key});
53             }
54            
55 0           $output .= $class->emit_line($request, "Parameters:");
56            
57 0           my @display = $request->params_for_display;
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 0         if ( ref $value eq 'ARRAY' )
68             {
69 0           $output .= $class->emit_line($request, '', $param, @$value);
70             }
71            
72             else
73             {
74 0           $output .= $class->emit_line($request, '', $param, $value);
75             }
76             }
77             }
78            
79             # If the user has directed that result counts are to be shown, and if any
80             # are available to show, then add those at the very top.
81            
82 0 0         if ( $request->display_counts )
83             {
84 0           my $counts = $request->result_counts;
85            
86 0           $output .= $class->emit_line($request, "Elapsed Time", sprintf("%.3g", $request->{elapsed}));
87 0           $output .= $class->emit_line($request, "Records Found", $counts->{found});
88 0           $output .= $class->emit_line($request, "Records Returned", $counts->{returned});
89             $output .= $class->emit_line($request, "Record Offset", $counts->{offset})
90 0 0 0       if defined $counts->{offset} && $counts->{offset} > 0;
91             }
92            
93             # If any warnings were generated on this request, add them in next.
94            
95 0 0         if ( my @msgs = $request->warnings )
96             {
97 0           $output .= $class->emit_line($request, "Warning:", $_) foreach @msgs;
98             }
99            
100             # If we have summary data to output, do so now.
101            
102 0 0 0       if ( $request->{summary_data} && $request->{summary_field_list} )
103             {
104 0           my @summary_fields = map { $_->{name} } @{$request->{summary_field_list}};
  0            
  0            
105 0           $output .= $class->emit_line($request, "Summary:");
106 0           $output .= $class->emit_line($request, @summary_fields);
107 0           $output .= $class->emit_record($request, $request->{summary_data}, $request->{summary_field_list});
108             }
109            
110             # If any header material was generated, add a line to introduce the start
111             # of the actual data.
112            
113 0 0         if ( $output ne '' )
114             {
115 0           $output .= $class->emit_line($request, "Records:");
116             }
117            
118             # Now, if any output fields were specified for this request, list them in
119             # a header line.
120            
121 0 0 0       if ( ref $field_list eq 'ARRAY' && @$field_list )
122             {
123 0           my @fields = map { $_->{name} } @$field_list;
  0            
124            
125 0           $output .= $class->emit_line($request, @fields);
126             }
127            
128             # Return the text that we have generated.
129            
130 0           return $output;
131             }
132              
133              
134             # generate_label ( key )
135             #
136             # Turn a field identifier (key) into a text label by turning underscores into
137             # spaces and capitalizing words.
138              
139             sub generate_label {
140            
141 0     0 0   my ($key) = @_;
142            
143 0           my @components = split(/_/, $key);
144 0           foreach ( @components ) { s/^url$/URL/ }
  0            
145 0           my $label = join(' ', map { ucfirst } @components);
  0            
146            
147 0           return $label;
148             }
149              
150              
151             # emit_empty ( )
152             #
153             # Return the string (if any) to output in lieu of an empty result set.
154              
155             sub emit_empty {
156            
157 0     0 0   my ($class, $request) = @_;
158            
159 0           return $class->emit_line($request, "THIS REQUEST RETURNED NO RECORDS");
160             }
161              
162              
163             # emit_footer ( request )
164             #
165             # None of the formats handled by this module involve any text after the last record
166             # is output, so we just return the empty string.
167              
168             sub emit_footer {
169              
170 0     0 0   return '';
171             }
172              
173              
174             # emit_record (request, record, field_list)
175             #
176             # Return a text line expressing a single record, according to the format
177             # specified in the request (comma-separated or tab-separated) and the
178             # given list of output field specifications.
179              
180             sub emit_record {
181              
182 0     0 0   my ($class, $request, $record, $field_list) = @_;
183            
184             # If no output fields were specified, we return the empty string.
185            
186 0 0         return '' unless ref $field_list eq 'ARRAY';
187            
188             # Otherwise, generate the list of values for the current line. For each output
189             # field, we take either the explicitly specified value or the value of the
190             # specified field from the record.
191            
192 0           my @values;
193            
194 0           foreach my $f ( @$field_list )
195             {
196 0           my $v = '';
197            
198             # First figure out what each value should be
199            
200 0 0 0       if ( defined $f->{value} )
    0          
201             {
202 0           $v = $f->{value};
203             }
204            
205             elsif ( defined $f->{field} && defined $record->{$f->{field}} )
206             {
207 0           $v = $record->{$f->{field}};
208             }
209            
210             # Cancel out the value if this field has the 'if_field' or 'not_field'
211             # attribute and the corresponding condition is true.
212            
213 0 0 0       $v = '' if $f->{if_field} and not $record->{$f->{if_field}};
214 0 0 0       $v = '' if $f->{not_field} and $record->{$f->{not_field}};
215            
216             # Cancel out any field with a 'dedup' attribute if its value is the same
217             # as the value of the field indicated by the attribute.
218            
219             $v = '' if $f->{dedup} and defined $record->{$f->{field}} and defined $record->{$f->{dedup}}
220 0 0 0       and $record->{$f->{field}} eq $record->{$f->{dedup}};
      0        
      0        
221            
222             # If the value is an array, join it into a string. If no joining
223             # string was specified, use a comma.
224            
225 0 0         if ( ref $v eq 'ARRAY' )
226             {
227 0   0       my $join = $f->{text_join} // q{, };
228 0           $v = join($join, @$v);
229             }
230            
231             # Now add the value to the list.
232            
233 0           push @values, $v;
234             }
235            
236 0           return $class->emit_line($request, @values);
237             }
238              
239              
240             # emit_line ( request, values... )
241             #
242             # Generate an output line containing the given values.
243              
244             sub emit_line {
245              
246 0     0 0   my $class = shift;
247 0           my $request = shift;
248            
249 0           my $linebreak = $request->linebreak;
250            
251 0 0         if ( $request->output_format eq 'tsv' )
252             {
253 0           return join("\t", map { tsv_clean($_) } @_) . $linebreak;
  0            
254             }
255            
256             else
257             {
258 0           return join(',', map { csv_clean($_) } @_) . $linebreak;
  0            
259             }
260             }
261              
262              
263             my (%TXTESCAPE) = ( '"' => '""', "'" => "''", "\t" => '\t', "\n" => '\n',
264             "\r" => '\r' ); #'
265              
266             # csv_clean ( string, quoted )
267             #
268             # Given a string value, return an equivalent string value that will be valid
269             # as part of a csv-format result. If 'quoted' is true, then all fields will
270             # be quoted. Otherwise, only those which contain commas or quotes will be.
271              
272             sub csv_clean {
273              
274 0     0 0   my ($string) = @_;
275            
276             # Return an empty string unless the value is defined.
277            
278 0 0         return '""' unless defined $string;
279            
280             # Do a quick check for okay characters. If there's nothing exotic, just
281             # return the quoted value.
282            
283 0 0         return '"' . $string . '"' unless $string =~ /[^a-zA-Z0-9 _.;:<>-]/;
284            
285             # Otherwise, we need to do some longer processing.
286            
287             # Turn any numeric character references into actual Unicode characters.
288             # The database does contain some of these.
289            
290 0           $string =~ s/&\#(\d)+;/pack("U", $1)/eg;
  0            
291            
292             # Next, double all quotes and textify whitespace control characters
293            
294 0           $string =~ s/("|\n|\r)/$TXTESCAPE{$1}/ge;
  0            
295            
296             # Finally, delete all other control characters (they shouldn't be in the
297             # database in the first place, but unfortunately some rows do contain
298             # them).
299            
300 0           $string =~ s/[\0-\037\177]//g;
301            
302 0           return '"' . $string . '"';
303             }
304              
305              
306             # tsv_clean ( string )
307             #
308             # Given a string value, return an equivalent string value that will be valid
309             # as part of a tsv-format result. If 'quoted' is true, then all fields will
310             # be quoted. Otherwise, only those which contain commas or quotes will be.
311              
312             sub tsv_clean {
313              
314 0     0 0   my ($string, $quoted) = @_;
315            
316             # Return an empty string unless the value is defined.
317            
318 0 0         return '' unless defined $string;
319            
320             # Do a quick check for okay characters. If there's nothing exotic, just
321             # return the value as-is.
322            
323 0 0         return $string unless $string =~ /^[a-zA-Z0-9 _.,;:<>-]/;
324            
325             # Otherwise, we need to do some longer processing.
326            
327             # Turn any numeric character references into actual Unicode characters.
328             # The database does contain some of these.
329            
330 0           $string =~ s/&\#(\d)+;/pack("U", $1)/eg;
  0            
331            
332             # Next, textify whitespace control characters
333            
334 0           $string =~ s/(\n|\t|\r)/$TXTESCAPE{$1}/ge;
  0            
335            
336             # Finally, delete all other control characters (they shouldn't be in the
337             # database in the first place, but unfortunately some rows do contain
338             # them).
339            
340 0           $string =~ s/[\0-\037\177]//g;
341            
342 0           return $string;
343             }
344              
345              
346             1;