File Coverage

blib/lib/Test/XHTML/Critic.pm
Criterion Covered Total %
statement 24 160 15.0
branch 0 70 0.0
condition 0 42 0.0
subroutine 8 28 28.5
pod 6 6 100.0
total 38 306 12.4


line stmt bran cond sub pod time code
1             package Test::XHTML::Critic;
2              
3 2     2   13248 use strict;
  2         3  
  2         77  
4 2     2   8 use warnings;
  2         2  
  2         60  
5              
6 2     2   9 use vars qw($VERSION);
  2         3  
  2         105  
7             $VERSION = '0.13';
8              
9             #----------------------------------------------------------------------------
10              
11             =head1 NAME
12              
13             Test::XHTML::Critic - Basic critique checks.
14              
15             =head1 SYNOPSIS
16              
17             my $txw = Test::XHTML::Critic->new();
18              
19             $txw->validate($content); # run compliance checks
20             my $results = $txw->results(); # retrieve results
21              
22             $txw->clear(); # clear all current errors and results
23             $txw->errors(); # all current errors reported
24             $txw->errstr(); # basic error message
25              
26             $txw->logfile($file); # logfile for verbose messages
27             $txw->logclean(1); # 1 = overwrite, 0 = append (default)
28              
29             =head1 DESCRIPTION
30              
31             This module attempts to check content for deprecated elements or missing
32             recommend elements. Some checks are based on W3C standards, while others are
33             from recognised usability resources.
34              
35             =cut
36              
37             # -------------------------------------
38             # Library Modules
39              
40 2     2   10 use base qw(Class::Accessor::Fast);
  2         3  
  2         195  
41 2     2   13 use File::Basename;
  2         3  
  2         155  
42 2     2   11 use File::Path;
  2         4  
  2         95  
43 2     2   9 use HTML::TokeParser;
  2         4  
  2         32  
44 2     2   6 use Data::Dumper;
  2         4  
  2         6211  
45              
46             # -------------------------------------
47             # Variables
48              
49             my @RESULTS = qw( PASS FAIL );
50              
51             my $FIXED = $HTML::TokeParser::VERSION >= 3.69 ? 1 : 0;
52              
53             # For a full list of valid W3C DTD types, please see
54             # http://www.w3.org/QA/2002/04/valid-dtd-list.html
55             my %declarations = (
56             '' => 3, # HTML5
57             'xhtml1-strict.dtd' => 2,
58             'xhtml1-transitional.dtd' => 2,
59             'xhtml1-frameset.dtd' => 2,
60             'html401-strict.dtd' => 1,
61             'html401-loose.dtd' => 1,
62             'html401-frameset.dtd' => 1,
63             );
64              
65             # For a list of deprecated tags and attributes, please see the following:
66             # * http://www.w3.org/TR/html4/index/attributes.html
67             # * http://www.w3.org/TR/2011/WD-html5-diff-20110525/
68             # * http://www.w3.org/TR/html5/obsolete.html#non-conforming-features
69              
70             my %deprecated = (
71             'a' => { 2 => { attr => [qw(charset coords datafld datasrc methods name rev shape urn)] } },
72             'acronym' => { 0 => { tag => [qw(abbr)] } },
73             'applet' => { 0 => { tag => [qw(object)] },
74             1 => { attr => [qw(align alt archive code codebase height hspace name object vspace width)] },
75             2 => { attr => [qw(datafld datasrc)] } },
76             'area' => { 2 => { attr => [qw(nohref)] } },
77             'b' => { 0 => { tag => [qw(strong)] } },
78             'basefont' => { 0 => { css => [qw(font color)] },
79             1 => { attr => [qw(color face size)] } },
80             'big' => { 0 => { css => [qw(font-size)] } },
81             'blockquote' => { 0 => { css => [qw(margin)] } },
82             'body' => { 1 => { attr => [qw(alink background bgcolor link text vlink)] },
83             2 => { attr => [qw(alink background bgcolor link marginbottom marginheight marginleft marginright margintop marginwidth text vlink)] } },
84             'br' => { 1 => { attr => [qw(clear)] } },
85             'button' => { 2 => { attr => [qw(datafld dataformatas datasrc)] } },
86             'caption' => { 1 => { attr => [qw(align)] },
87             2 => { attr => [qw(align)] } },
88             'center' => { 0 => { css => [qw(text-align)] } },
89             'col' => { 2 => { attr => [qw(align char charoff valign width)] } },
90             'dir' => { 0 => { tag => [qw(ul)] },
91             1 => { attr => [qw(compact)] } },
92             'div' => { 1 => { attr => [qw(align)] },
93             2 => { attr => [qw(align datafld dataformatas datasrc)] } },
94             'dl' => { 1 => { attr => [qw(compact)] },
95             2 => { attr => [qw(compact)] } },
96             'embed' => { 0 => { tag => [qw(object)] },
97             2 => { attr => [qw(align hspace name vspace)] },
98             3 => { tag => [qw(embed)] } }, # reinstated in HTML5
99             'fieldset' => { 2 => { attr => [qw(datafld)] } },
100             'font' => { 0 => { css => [qw(font color)] },
101             1 => { attr => [qw(color face size)] } },
102             'form' => { 2 => { attr => [qw(name)] } },
103             'frame' => { 0 => { tag => [qw(iframe)] },
104             2 => { attr => [qw(datafld datasrc name)] } },
105             'frameset' => { 0 => { tag => [qw(iframe)] } },
106             'h1' => { 1 => { attr => [qw(align)] } },
107             'h2' => { 1 => { attr => [qw(align)] } },
108             'h3' => { 1 => { attr => [qw(align)] } },
109             'h4' => { 1 => { attr => [qw(align)] } },
110             'h5' => { 1 => { attr => [qw(align)] } },
111             'h6' => { 1 => { attr => [qw(align)] } },
112             'head' => { 2 => { attr => [qw(profile)] } },
113             'hr' => { 1 => { attr => [qw(align noshade size width)] },
114             2 => { attr => [qw(color)] } },
115             'html' => { 1 => { attr => [qw(version)] } },
116             'i' => { 0 => { css => [qw(font-style)] } },
117             'iframe' => { 1 => { attr => [qw(align)] },
118             2 => { attr => [qw(align allowtransparency datafld datasrc frameborder hspace longdesc marginheight marginwidth name scrolling vspace)] } },
119             'img' => { 1 => { attr => [qw(align border hspace vspace)] },
120             2 => { attr => [qw(datafld datasrc longdesc lowsrc name)] } },
121             'input' => { 1 => { attr => [qw(align)] },
122             2 => { attr => [qw(datafld dataformatas datasrc hspace usemap vspace)] } },
123             'isindex' => { 0 => { tag => [qw(input)] },
124             1 => { attr => [qw(prompt)] } },
125             'label' => { 2 => { attr => [qw(datafld dataformatas datasrc)] } },
126             'layer' => { 0 => { css => [qw(position)] } },
127             'legend' => { 1 => { attr => [qw(align)] },
128             2 => { attr => [qw(datafld dataformatas datasrc)] } },
129             'li' => { 1 => { attr => [qw(type value)] } },
130             'link' => { 2 => { attr => [qw(charset methods rev target urn)] } },
131             'map' => { 2 => { attr => [qw(name)] } },
132             'marquee' => { 2 => { attr => [qw(datafld dataformatas datasrc)] } },
133             'menu' => { 0 => { tag => [qw(ul)] },
134             1 => { attr => [qw(compact)] } },
135             'meta' => { 2 => { attr => [qw(scheme)] } },
136             'noframes' => { 0 => { tag => [qw(iframe)] } },
137             'object' => { 1 => { attr => [qw(align border hspace vspace)] },
138             2 => { attr => [qw(archive classid code codebase codetype datafld dataformatas datasrc declare standby)] } },
139             'ol' => { 1 => { attr => [qw(compact start type)] } },
140             'option' => { 2 => { attr => [qw(dataformatas datasrc name)] } },
141             'param' => { 2 => { attr => [qw(datafld type valuetype)] } },
142             'p' => { 1 => { attr => [qw(align)] } },
143             'pre' => { 1 => { attr => [qw(width)] } },
144             's' => { 0 => { css => [qw(text-decoration)] } },
145             'script' => { 1 => { attr => [qw(language)] },
146             2 => { attr => [qw(event for)] } },
147             'select' => { 2 => { attr => [qw(datafld dataformatas datasrc)] } },
148             'span' => { 2 => { attr => [qw(datafld dataformatas datasrc)] } },
149             'strike' => { 0 => { css => [qw(text-decoration)] } },
150             'table' => { 1 => { attr => [qw(align bgcolor)] },
151             2 => { attr => [qw(background cellpadding cellspacing dataformatas datapagesize datasrc frame rules summary width)] } },
152             'tbody' => { 2 => { attr => [qw(align background char charoff valign)] } },
153             'td' => { 1 => { attr => [qw(bgcolor height nowrap width)] },
154             2 => { attr => [qw(abbr align axis background char charoff valign)] } },
155             'textarea' => { 2 => { attr => [qw(datafld datasrc)] } },
156             'tfoot' => { 2 => { attr => [qw(align background char charoff valign)] } },
157             'th' => { 1 => { attr => [qw(bgcolor height nowrap width)] },
158             2 => { attr => [qw(abbr align axis background char charoff valign)] } },
159             'thead' => { 2 => { attr => [qw(align background char charoff valign)] } },
160             'tr' => { 1 => { attr => [qw(bgcolor)] },
161             2 => { attr => [qw(align background char charoff valign)] } },
162             'tt' => { 0 => { css => [qw(text-decoration)] } },
163             'u' => { 0 => { css => [qw(text-decoration)] } },
164             'ul' => { 1 => { attr => [qw(compact type)] } },
165             );
166              
167             my @TAGS = (
168             # list taken from http://www.w3schools.com/tags/default.asp
169             'a', 'abbr', 'acronym', 'address', 'applet', 'area',
170             'b', 'base', 'basefont', 'bdo', 'big', 'blockquote', 'body', 'br', 'button',
171             'caption', 'center', 'cite', 'code', 'col', 'colgroup',
172             'dd', 'del', 'dfn', 'dir', 'div', 'dl', 'dt',
173             'em', 'embed',
174             'fieldset', 'font', 'form', 'frame', 'frameset',
175             'head', 'h1', 'h2', 'h3', 'h4', 'h5', 'h6', 'hr', 'html',
176             'i', 'iframe', 'img', 'input', 'ins', 'isindex',
177             'kbd',
178             'label', 'layer', 'legend', 'li', 'link',
179             'map', 'menu', 'meta',
180             'noframes', 'noscript',
181             'object', 'ol', 'optgroup', 'option',
182             'p', 'param', 'pre',
183             'q',
184             's', 'samp', 'script', 'select', 'small', 'span', 'strike', 'strong', 'style', 'summary', 'sub',
185             'table', 'tbody', 'td', 'textarea', 'tfoot', 'th', 'thead', 'title', 'tr', 'tt',
186             'u', 'ul',
187             'var',
188              
189             '/form'
190             );
191              
192             # -------------------------------------
193             # Public Methods
194              
195             sub new {
196 0     0 1   my $proto = shift; # get the class name
197 0   0       my $class = ref($proto) || $proto;
198              
199             # private data
200 0           my $self = { dtdtype => 0 };
201 0           $self->{RESULTS}{$_} = 0 for(@RESULTS);
202              
203 0           bless ($self, $class);
204 0           return $self;
205             }
206              
207             sub DESTROY {
208 0     0     my $self = shift;
209             }
210              
211             __PACKAGE__->mk_accessors(qw( logfile logclean ));
212              
213 0     0 1   sub validate { _process_checks(@_); }
214 0     0 1   sub results { _process_results(@_); }
215              
216 0     0 1   sub clear { my $self = shift; $self->{ERRORS} = undef; $self->_reset_results(); }
  0            
  0            
217 0     0 1   sub errors { my $self = shift; return $self->{ERRORS}; }
  0            
218 0     0 1   sub errstr { my $self = shift; return $self->_print_errors(); }
  0            
219              
220             # -------------------------------------
221             # Private Methods
222              
223             sub _process_results {
224 0     0     my $self = shift;
225 0           my %results = map {$_ => $self->{RESULTS}{$_}} @RESULTS;
  0            
226 0           $self->_log( sprintf "%8s%d\n", "$_:", $results{$_} ) for(@RESULTS);
227 0           return \%results;
228             }
229              
230             sub _reset_results {
231 0     0     my $self = shift;
232 0           $self->{RESULTS}{$_} = 0 for(@RESULTS);
233             }
234              
235             sub _print_errors {
236 0     0     my $self = shift;
237 0           my $str = "\nErrors:\n" ;
238 0           my $i = 1;
239 0           for my $error (@{$self->{ERRORS}}) {
  0            
240 0           $str .= "$i. $error->{error}: $error->{message}";
241 0 0         $str .= " [$error->{ref}]" if($error->{ref});
242 0 0 0       $str .= " [row $error->{row}, column $error->{col}]" if($FIXED && ($error->{row} || $error->{col}));
      0        
243 0           $str .= "\n";
244 0           $i++;
245             }
246 0           return $str;
247             }
248              
249             # -------------------------------------
250             # Subroutines
251              
252             # TODO
253             # * privacy policy
254             # * home page link
255              
256             sub _process_checks {
257 0     0     my $self = shift;
258 0           my $html = shift;
259              
260             # clear data from previous tests.
261 0           $self->{$_} = undef for(qw(input label form links));
262              
263             #push @{ $self->{ERRORS} }, {
264             # error => "debug",
265             # message => "VERSION=$HTML::TokeParser::VERSION, FIXED=$FIXED"
266             #};
267              
268             #use Data::Dumper;
269             #print STDERR "#html=".Dumper($html);
270              
271 0 0         if($html) {
272 0 0         my $p = $FIXED
273             ? HTML::TokeParser->new( \$html,
274             start => "'S',tagname,attr,attrseq,text,line,column",
275             end => "'E',tagname,text,line,column"
276             )
277             : HTML::TokeParser->new( \$html );
278              
279             #print STDERR "#p=".Dumper($p);
280              
281             # determine declaration and the case requirements
282 0           my $token = $p->get_token();
283 0 0 0       if($token && $token->[0] eq 'D') {
284 0           my $declaration = $token->[1];
285 0           $declaration =~ s/\s+/ /sg;
286 0           for my $type (keys %declarations) {
287 0 0         if($declaration =~ /$type/) {
288 0           $self->{dtdtype} = $declarations{$type};
289 0           last;
290             }
291             }
292             } else {
293 0           $p->unget_token($token);
294             }
295              
296 0           while( my $tag = $p->get_tag( @TAGS ) ) {
297              
298 0 0         if($tag->[0] eq uc $tag->[0]) {
299 0           $self->_check_case($tag);
300 0           $tag->[0] = lc $tag->[0];
301             }
302              
303 0           $self->_check_deprecated($tag);
304              
305 0 0         if($tag->[0] eq 'map') {
    0          
    0          
    0          
    0          
306 0           $self->_check_name($tag);
307             } elsif($tag->[0] eq 'img') {
308 0           $self->_check_name($tag);
309 0           $self->_check_size($tag);
310             } elsif($tag->[0] eq 'a') {
311 0           $self->_check_policy1($tag,$p);
312             } elsif($tag->[0] eq 'script') {
313 0           $self->_check_language($tag);
314             } elsif($tag->[0] eq 'title') {
315 0           $self->_check_title($tag,$p);
316             }
317             }
318              
319 0           $self->_check_policy2();
320              
321              
322             } else {
323 0           push @{ $self->{ERRORS} }, {
  0            
324             #ref => 'Best Practices Recommedation only',
325             error => "missing content",
326             message => 'no XHTML content found'
327             };
328             }
329              
330 0 0         if($self->{ERRORS}) {
331 0           $self->_log( "FAIL\n" );
332 0           $self->{RESULTS}{FAIL}++;
333             } else {
334 0           $self->_log( "PASS\n" );
335 0           $self->{RESULTS}{PASS}++;
336             }
337             }
338              
339             # -------------------------------------
340             # Private Methods : Check Routines
341              
342             sub _check_case {
343 0     0     my ($self,$tag) = @_;
344              
345 0 0         if($self->{dtdtype} == 1) {
    0          
346 0           push @{ $self->{ERRORS} }, {
  0            
347             #ref => 'Best Practices Recommedation only',
348             error => "C001",
349             message => "W3C recommends use of lowercase in HTML 4 (<$tag->[0]>)",
350             row => $tag->[2],
351             col => $tag->[3]
352             };
353             } elsif($self->{dtdtype} == 2) {
354 0           push @{ $self->{ERRORS} }, {
  0            
355             #ref => 'Best Practices Recommedation only',
356             error => "C002",
357             message => "declaration requires lowercase tags (<$tag->[0]>)",
358             row => $tag->[2],
359             col => $tag->[3]
360             };
361             }
362             }
363              
364             sub _check_deprecated {
365 0     0     my ($self,$tag) = @_;
366              
367 0 0         return unless($deprecated{ $tag->[0] });
368              
369 0           my ($elem,@css);
370 0           for my $dtdtype (sort {$b <=> $a} keys %{$deprecated{$tag->[0]}}) {
  0            
  0            
371 0   0       $elem ||= $deprecated{$tag->[0]}{$dtdtype}{tag};
372 0 0         push @css, @{ $deprecated{$tag->[0]}{$dtdtype}{css} } if($deprecated{$tag->[0]}{$dtdtype}{css});
  0            
373              
374 0 0         next unless($self->{dtdtype} > $dtdtype);
375 0 0         next unless($deprecated{$tag->[0]}{$dtdtype}{attr});
376              
377 0           for my $attr (@{ $deprecated{$tag->[0]}{$dtdtype}{attr} }) {
  0            
378 0 0         if($tag->[1]{$attr}) {
379 0           push @{ $self->{ERRORS} }, {
  0            
380             #ref => 'Best Practices Recommedation only',
381             error => "C010",
382             message => "'$attr' attribute deprecated in <$tag->[0]> tag",
383             row => $tag->[4],
384             col => $tag->[5]
385             };
386             }
387             }
388             }
389              
390 0 0 0       if($elem && $elem->[0] ne $tag->[0]) {
    0          
391 0           push @{ $self->{ERRORS} }, {
  0            
392             #ref => 'Best Practices Recommedation only',
393             error => "C011",
394             message => "<$tag->[0]> has been deprecated in favour of <$elem->[0]>",
395             row => $tag->[4],
396             col => $tag->[5]
397             };
398             } elsif(@css) {
399 0           push @{ $self->{ERRORS} }, {
  0            
400             #ref => 'Best Practices Recommedation only',
401             error => "C012",
402             message => "<$tag->[0]> has been deprecated in favour of CSS elements (".join(',',@css).")",
403             row => $tag->[4],
404             col => $tag->[5]
405             };
406             }
407             }
408              
409             sub _check_name {
410 0     0     my ($self,$tag) = @_;
411              
412 0 0         if($tag->[1]{name}) {
413 0           push @{ $self->{ERRORS} }, {
  0            
414             #ref => 'Best Practices Recommedation only',
415             error => "C003",
416             message => "name attribute deprecated in <$tag->[0]> tag",
417             row => $tag->[4],
418             col => $tag->[5]
419             };
420             }
421             }
422              
423             sub _check_size {
424 0     0     my ($self,$tag) = @_;
425              
426 0 0 0       if(!$tag->[1]{width} || !$tag->[1]{height}) {
427 0           push @{ $self->{ERRORS} }, {
  0            
428             #ref => 'Best Practices Recommedation only',
429             error => "C004",
430             message => "width and height attributes allow for pre-rendering <$tag->[0]> tags ($tag->[1]{src})",
431             row => $tag->[4],
432             col => $tag->[5]
433             };
434             }
435             }
436              
437             sub _check_language {
438 0     0     my ($self,$tag) = @_;
439              
440 0 0         if($tag->[1]{language}) {
441 0           push @{ $self->{ERRORS} }, {
  0            
442             #ref => 'Best Practices Recommedation only',
443             error => "C005",
444             message => "language attribute deprecated in <$tag->[0]> tag",
445             row => $tag->[4],
446             col => $tag->[5]
447             };
448             }
449             }
450              
451             sub _check_policy1 {
452 0     0     my ($self,$tag,$p) = @_;
453              
454 0           my $x = $p->get_text();
455              
456 0 0 0       if( $x =~ /privacy policy/i
      0        
      0        
      0        
      0        
457             || ($tag->[1]{title} && $tag->[1]{title} =~ /privacy policy/i)
458             || $x =~ /terms.*conditions/i
459             || ($tag->[1]{title} && $tag->[1]{title} =~ /terms.*conditions/i) ) {
460 0           $self->{policy}{privacy} = 1;
461             }
462              
463 0 0 0       if( $x =~ /home/i
      0        
464             || ($tag->[1]{title} && $tag->[1]{title} =~ /home/i) ) {
465 0           $self->{policy}{home} = 1;
466             }
467             }
468              
469             sub _check_policy2 {
470 0     0     my ($self) = @_;
471              
472 0 0         if(!$self->{policy}{privacy}) {
473 0           push @{ $self->{ERRORS} }, {
  0            
474             #ref => 'Best Practices Recommedation only',
475             error => "C006",
476             message => "no link to a privacy policy"
477             };
478             }
479              
480 0 0         if(!$self->{policy}{home}) {
481 0           push @{ $self->{ERRORS} }, {
  0            
482             #ref => 'Best Practices Recommedation only',
483             error => "C007",
484             message => "no home page link"
485             };
486             }
487             }
488              
489             sub _check_title {
490 0     0     my ($self,$tag,$p) = @_;
491              
492 0           my $x = $p->get_text();
493              
494 0 0         if(length $x > 64) {
495 0           push @{ $self->{ERRORS} }, {
  0            
496             #ref => 'Best Practices Recommedation only',
497             error => "C008",
498             message => "W3C recommend should not be longer than 64 characters [".(substr($x,0,64))."]", </td> </tr> <tr> <td class="h" > <a name="499">499</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> row => $tag->[4], </td> </tr> <tr> <td class="h" > <a name="500">500</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> col => $tag->[5] </td> </tr> <tr> <td class="h" > <a name="501">501</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="502">502</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="503">503</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="504">504</a> </td> <td class="c0" > 0 </td> <td class="c0" > <a href="blib-lib-Test-XHTML-Critic-pm--branch.html#504-1"> 0 </a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> if($x =~ /['"(){}\[\]]/) { </td> </tr> <tr> <td class="h" > <a name="505">505</a> </td> <td class="c0" > 0 </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> push @{ $self->{ERRORS} }, { </td> </tr> <tr> <td class="h" > <a > </a> </td> <td class="c0" > 0 </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="506">506</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> #ref => 'Best Practices Recommedation only', </td> </tr> <tr> <td class="h" > <a name="507">507</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> error => "C009", </td> </tr> <tr> <td class="h" > <a name="508">508</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> message => qq!avoid using the characters '"(){}[] in <title> tag - <$x>!, </td> </tr> <tr> <td class="h" > <a name="509">509</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> row => $tag->[4], </td> </tr> <tr> <td class="h" > <a name="510">510</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> col => $tag->[5] </td> </tr> <tr> <td class="h" > <a name="511">511</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> }; </td> </tr> <tr> <td class="h" > <a name="512">512</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="513">513</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="514">514</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="515">515</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # ------------------------------------- </td> </tr> <tr> <td class="h" > <a name="516">516</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> # Private Methods : Other </td> </tr> <tr> <td class="h" > <a name="517">517</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="518">518</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> sub _log { </td> </tr> <tr> <td class="h" > <a name="519">519</a> </td> <td class="c0" > 0 </td> <td >   </td> <td >   </td> <td class="c0" > <a href="blib-lib-Test-XHTML-Critic-pm--subroutine.html#519-1"> 0 </a> </td> <td >   </td> <td >   </td> <td class="s"> my $self = shift; </td> </tr> <tr> <td class="h" > <a name="520">520</a> </td> <td class="c0" > 0 </td> <td class="c0" > <a href="blib-lib-Test-XHTML-Critic-pm--branch.html#520-1"> 0 </a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $log = $self->logfile or return; </td> </tr> <tr> <td class="h" > <a name="521">521</a> </td> <td class="c0" > 0 </td> <td class="c0" > <a href="blib-lib-Test-XHTML-Critic-pm--branch.html#521-1"> 0 </a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> mkpath(dirname($log)) unless(-f $log); </td> </tr> <tr> <td class="h" > <a name="522">522</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="523">523</a> </td> <td class="c0" > 0 </td> <td class="c0" > <a href="blib-lib-Test-XHTML-Critic-pm--branch.html#523-1"> 0 </a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $mode = $self->logclean ? 'w+' : 'a+'; </td> </tr> <tr> <td class="h" > <a name="524">524</a> </td> <td class="c0" > 0 </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $self->logclean(0); </td> </tr> <tr> <td class="h" > <a name="525">525</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="526">526</a> </td> <td class="c0" > 0 </td> <td class="c0" > <a href="blib-lib-Test-XHTML-Critic-pm--branch.html#526-1"> 0 </a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> my $fh = IO::File->new($log,$mode) or die "Cannot write to log file [$log]: $!\n"; </td> </tr> <tr> <td class="h" > <a name="527">527</a> </td> <td class="c0" > 0 </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> print $fh @_; </td> </tr> <tr> <td class="h" > <a name="528">528</a> </td> <td class="c0" > 0 </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> $fh->close; </td> </tr> <tr> <td class="h" > <a name="529">529</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> } </td> </tr> <tr> <td class="h" > <a name="530">530</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="531">531</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> 1; </td> </tr> <tr> <td class="h" > <a name="532">532</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s">   </td> </tr> <tr> <td class="h" > <a name="533">533</a> </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td >   </td> <td class="s"> __END__ </td> </tr> </table> </body> </html>