File Coverage

blib/lib/HTTP/OAIPMH/Log.pm
Criterion Covered Total %
statement 121 121 100.0
branch 28 30 93.3
condition 8 9 100.0
subroutine 21 21 100.0
pod 11 12 91.6
total 189 193 98.4


line stmt bran cond sub pod time code
1             package HTTP::OAIPMH::Log;
2              
3             =head1 NAME
4              
5             HTTP::OAIPMH::Log - Log of validation results
6              
7             =head1 SYNOPSIS
8              
9             Validation logging for L. Stores log of information
10             as an array of entries in $obj->log, where each entry is itself an array
11             where the first element is the type (indicated by a string) and then additional
12             information.
13              
14             Also supports output of a text summary (markdown) and/or JSON data
15             during operation if the $obj->filehandles array is set to include one
16             or more filehandle and types for output.
17              
18             Example use:
19              
20             my $log = HTTP::OAIPMH::Log->new;
21             $log->fh(\*STDOUT);
22             $log->start("First test");
23             ...
24             $log->note("Got some data");
25             ...
26             if ($good) {
27             $log->pass("It was good, excellent");
28             } else {
29             $log->fail("Should have been good but wasn't");
30             }
31              
32             =cut
33              
34 1     1   12766 use strict;
  1         1  
  1         25  
35 1     1   781 use CGI qw(escapeHTML);
  1         21136  
  1         5  
36 1     1   696 use JSON qw(encode_json);
  1         9436  
  1         3  
37 1     1   139 use base qw(Class::Accessor::Fast);
  1         2  
  1         455  
38             HTTP::OAIPMH::Log->mk_accessors( qw(log filehandles num_pass num_fail num_warn) );
39              
40             =head2 METHODS
41              
42             =head3 new(%args)
43              
44             Create new HTTP::OAIPMH::Log and optionally set values for any of the
45             attributes. All attributes also have accessors provided via
46             L:
47              
48             log - internal data structure for log messages (array of arrays)
49             fh - set to a filehandle to write log messages as logging is done
50             num_pass - number of pass messages
51             num_fail - number of fail messages
52             num_warn - number of warn messages
53              
54             =cut
55              
56             sub new {
57 9     9 1 264 my $this=shift;
58             # uncoverable condition false
59 9   66     34 my $class=ref($this) || $this;
60 9         31 my $self={'log'=>[],
61             'filehandles'=>[],
62             'num_pass'=>0,
63             'num_fail'=>0,
64             'num_warn'=>0,
65             @_};
66 9         10 bless($self, $class);
67 9         16 return($self);
68             }
69              
70              
71             =head3 fh(@fhspecs)
72              
73             Set the list of filehandle specs that will be written to, clearing
74             any that already exist. Each entry in the @fhspec array should be a
75             either a filehandle or an arrayref [$fh,$type] used to call
76             $self->add_fh($fh,$type) to set the type as well.
77              
78             Returns number of filehandles in the list to write to.
79              
80             =cut
81              
82             sub fh {
83 13     13 1 1978 my $self=shift;
84 13 100       29 if (@_) {
85 11         12 $self->{filehandles} = [];
86 11         22 foreach my $fhspec (@_) {
87 12 100       26 $fhspec = [$fhspec] unless (ref($fhspec) eq 'ARRAY');
88 12         18 $self->add_fh(@$fhspec);
89             }
90             }
91 13         10 return(scalar(@{$self->{filehandles}}));
  13         38  
92             }
93              
94              
95             =head3 add_fh($fh,$type)
96              
97             Add a filehandle to the logger. If $type is set equal to 'json' then
98             JSON will be written, els if 'html then HTML will be written, otherwise
99             text is output in markdown format. The call is ignored unless $fh is True.
100              
101             =cut
102              
103             sub add_fh {
104 12     12 1 11 my $self=shift;
105 12         13 my ($fh,$type)=@_;
106 12 50       13 return() if (not $fh);
107 12   100     30 $type ||= 'md';
108 12         10 push(@{$self->{filehandles}},{'fh'=>$fh,'type'=>$type});
  12         29  
109 12         18 return($fh);
110             }
111              
112              
113             =head3 num_total()
114              
115             Return the total number of pass and fail events recorded. Note
116             that this doesn't include warnings.
117              
118             =cut
119              
120             sub total {
121 6     6 0 627 my $self=shift;
122 6         18 return( $self->{num_pass}+$self->{num_fail} );
123             }
124              
125              
126             =head3 start($title)
127              
128             Start a test or section and record a title.
129              
130             =cut
131              
132             sub start {
133 2     2 1 389 my $self=shift;
134 2         2 my ($title)=@_;
135 2         6 return $self->_add('TITLE',$title);
136             }
137              
138              
139             =head3 request($url,$type,$content)
140              
141             Add a note of the HTTP request used in this test. Must specify
142             the $url, may include the $type (GET|POST) and for POST
143             the $content.
144              
145             =cut
146              
147             sub request {
148 6     6 1 691 my $self=shift;
149 6         9 my ($url,$type,$content)=@_;
150 6   100     45 return $self->_add('REQUEST',$url,$type||'',$content||'');
      100        
151             }
152              
153              
154             =head3 note($note)
155              
156             Add note of extra information that doesn't impact validity.
157              
158             =cut
159              
160             sub note {
161 3     3 1 237 my $self=shift;
162 3         4 my ($note)=@_;
163 3         5 return $self->_add('NOTE',$note);
164             }
165              
166              
167             =head3 fail($msg)
168              
169             Record a failure and increment the $obj->num_fail count.
170              
171             =cut
172              
173             sub fail {
174 4     4 1 6 my $self=shift;
175 4         4 my ($msg)=@_;
176 4         5 $self->{num_fail}++;
177 4         6 return $self->_add('FAIL',$msg);
178             }
179              
180              
181             =head3 warn($msg)
182              
183             Record a warning and increment the $obj->num_warn count.
184              
185             =cut
186              
187             sub warn {
188 2     2 1 227 my $self=shift;
189 2         3 my ($msg)=@_;
190 2         3 $self->{num_warn}++;
191 2         4 return $self->_add('WARN',$msg);
192             }
193              
194              
195             =head3 pass($msg)
196              
197             Record a success and increment the $obj->num_pass count. Must have
198             a message $msg explaining what has passed.
199              
200             =cut
201              
202             sub pass {
203 6     6 1 245 my $self=shift;
204 6         8 my ($msg)=@_;
205 6         7 $self->{num_pass}++;
206 6         7 return $self->_add('PASS',$msg);
207             }
208              
209              
210             # _add($type,@content)
211             #
212             # Add an entry to @{$obj->log} which has type $type and then
213             # a set of content elements @content (assumed to be scalars).
214             # Used by all the pass, fail, warn, start methods.
215             #
216             # In addition to recording the data in $self->{log} array, will
217             # write output in markdown, HTML or JSON to each of the filehandles
218             # in $self->filehandles.
219             #
220             sub _add {
221 31     31   31 my $self=shift;
222 31         27 my $type=shift;
223 31         45 my $msg=join(' ',@_);
224             # do a little tidy on the message
225 31         73 $msg=~s/\s+$//;
226 31         27 $msg=~s/\n/ /g;
227 31         21 push(@{$self->{log}}, [$type,$msg]);
  31         73  
228 31 50       57 if (scalar($self->filehandles)>0) {
229 31         153 $self->_write_to_filehandles([$type,$msg], $self->filehandles);
230             }
231 31         96 return(1);
232             }
233              
234              
235             # _write_to_filehandles($entry, $filehandles) - write one entry
236             # to zero of more filehandles with formats as specified in
237             # $filehandles data.
238             #
239             sub _write_to_filehandles {
240 31     31   82 my $self = shift(@_);
241 31         30 my ($entry, $filehandles) = @_;
242 31         30 my ($type, $msg) = @$entry;
243 31         39 foreach my $fhd (@$filehandles) {
244 8 100       20 if ($fhd->{'type'} eq 'json') {
    100          
245 1         1 print {$fhd->{'fh'}} $self->_json($type,$msg);
  1         4  
246             } elsif ($fhd->{'type'} eq 'html') {
247 2         1 print {$fhd->{'fh'}} $self->_html($type,$msg);
  2         5  
248             } else {
249 5         4 print {$fhd->{'fh'}} $self->_md($type,$msg);
  5         9  
250             }
251             }
252 31         140 return(1);
253             }
254              
255              
256             # _md($type, $msg) - Return markdown for a log entry
257             #
258             sub _md {
259 9     9   5 my $self=shift;
260 9         9 my ($type,$msg)=@_;
261 9         9 my $md_prefix = '';
262 9         5 my $md_suffix = "\n";
263 9 100       12 if ($type eq 'TITLE') {
264 2         2 $md_prefix = "\n### ";
265 2         3 $md_suffix = "\n\n";
266             } else {
267 7         17 $md_prefix = sprintf("%-8s ",$type.':');
268             }
269 9         26 return($md_prefix.$msg.$md_suffix);
270             }
271              
272             # _html($type,$msg) - Return HTML for a log entry, using
273             # classes to allow CSS styling
274             #
275             sub _html {
276 2     2   3 my $self=shift;
277 2         2 my ($type,$msg)=@_;
278 2 100       5 if ($type eq 'TITLE') {
279 1         4 return('

'.$msg."

\n");
280             } else {
281             return('
'.
282 1         4 ''.scalar(@{$self->{log}}).' '.
  1         6  
283             ''.$type.' '.
284             ''.$msg."\n");
285             }
286             }
287              
288             # _json($fh,$type,$msg) - Return one-line JSON for a
289             # log entry, terminate with \n.
290             #
291             sub _json {
292 1     1   2 my $self=shift;
293 1         1 my ($type,$msg)=@_;
294             return(encode_json({type=>$type, msg=>$msg,
295 1         2 num=>scalar(@{$self->{log}}),
  1         3  
296             pass=>$self->num_pass,
297             fail=>$self->num_fail,
298             warn=>$self->num_warn,
299             timestamp=>''.localtime() })."\n");
300             }
301              
302              
303             =head2 INTERROGATING THE LOG
304              
305             =head3 failures()
306              
307             Return Markdown summary of failure log entries, along with the appropriate
308             titles and request details. Will return empty string if there are no
309             failures in the log.
310              
311             =cut
312              
313             sub failures {
314 2     2 1 2 my $self=shift;
315 2 100       4 return('') if ($self->num_fail==0); #shirt circuit if no failures
316              
317 1         5 my $str="\n## Failure summary\n";
318 1         2 my $last_title='Unknown title';
319 1         1 my $last_request=undef;
320 1         1 for my $entry (@{$self->log}) {
  1         3  
321 12         16 my ($type, $msg) = @$entry;
322 12 100       28 if ($type eq 'TITLE') {
    100          
    100          
323 1         2 $last_title=$entry;
324 1         2 $last_request=undef;
325             } elsif ($type eq 'REQUEST') {
326 2         2 $last_request=$entry;
327             } elsif ($type eq 'FAIL') {
328 2 100       4 $str .= $self->_md(@$last_title) if (defined $last_title);
329 2 100       7 $str .= $self->_md(@$last_request) if (defined $last_request);
330 2         5 $str .= $self->_md(@$entry);
331 2         2 $last_title = undef;
332 2         3 $last_request = undef;
333             }
334             }
335 1         2 return($str);
336             }
337              
338              
339              
340             =head3 last_match($regex)
341              
342             Return last log entry where the message matches $regex, else
343             empty return.
344              
345             =cut
346              
347             sub last_match {
348 3     3 1 337 my $self=shift;
349 3         4 my ($regex)=@_;
350 3         2 foreach my $entry (reverse(@{$self->log})) {
  3         6  
351 23 100       55 if ($entry->[1]=~$regex) {
352 2         8 return($entry);
353             }
354             }
355 1         24 return;
356             }
357              
358             1;