File Coverage

blib/lib/HTML/Lint/Parser.pm
Criterion Covered Total %
statement 191 192 99.4
branch 71 72 98.6
condition 26 30 86.6
subroutine 27 27 100.0
pod 2 2 100.0
total 317 323 98.1


line stmt bran cond sub pod time code
1             package HTML::Lint::Parser;
2              
3 39     39   47084 use warnings;
  39         73  
  39         971  
4 39     39   153 use strict;
  39         54  
  39         785  
5              
6 39     39   16314 use HTML::Parser 3.20;
  39         172097  
  39         1086  
7 39     39   13941 use HTML::Tagset 3.03;
  39         38871  
  39         1014  
8              
9 39     39   545 use HTML::Lint::Error ();
  39         69  
  39         937  
10 39     39   13298 use HTML::Lint::HTML4 qw( %isKnownAttribute %isRequired %isNonrepeatable %isObsolete );
  39         106  
  39         5354  
11 39     39   246 use HTML::Entities qw( %char2entity %entity2char );
  39         60  
  39         2683  
12              
13 39     39   187 use parent 'HTML::Parser';
  39         55  
  39         132  
14              
15             =head1 NAME
16              
17             HTML::Lint::Parser - Parser for HTML::Lint. No user-serviceable parts inside.
18              
19             =head1 VERSION
20              
21             Version 2.32
22              
23             =cut
24              
25             our $VERSION = '2.32';
26              
27             =head1 SYNOPSIS
28              
29             See L for all the gory details.
30              
31             =head1 METHODS
32              
33             =head2 new( $gripe )
34              
35             Constructor for the main parsing object. The I<$gripe> argument
36             is a coderef to a function that can handle errors from the parser.
37             It is only ever (so far) C.
38              
39             =cut
40              
41             sub new {
42 47     47 1 102 my $class = shift;
43 47         85 my $gripe = shift;
44              
45 47         692 my $self =
46             HTML::Parser->new(
47             api_version => 3,
48             start_document_h => [ \&_start_document, 'self' ],
49             end_document_h => [ \&_end_document, 'self,line,column' ],
50             start_h => [ \&_start, 'self,tagname,line,column,@attr' ],
51             end_h => [ \&_end, 'self,tagname,line,column,tokenpos,@attr' ],
52             comment_h => [ \&_comment, 'self,tagname,line,column,text' ],
53             text_h => [ \&_text, 'self,text' ],
54             strict_names => 0,
55             empty_element_tags => 1,
56             attr_encoded => 1,
57             );
58 47         4468 bless $self, $class;
59              
60 47         203 $self->{_gripe} = $gripe;
61 47         104 $self->{_stack} = [];
62 47         113 $self->{_directives} = {};
63              
64 47         128 return $self;
65             }
66              
67             =head2 $parser->gripe( $errorcode, [ arg1=>val1, ...] )
68              
69             Calls the passed-in gripe function.
70              
71             If a given directive has been set to turn off a given message, then
72             the parent gripe never gets called.
73              
74             =cut
75              
76             sub gripe {
77 96     96 1 148 my $self = shift;
78 96         127 my $errorcode = shift;
79              
80 96 100       192 if ( $self->_displayable( $errorcode ) ) {
81 91         226 $self->{_gripe}->( $errorcode, @_ );
82             }
83              
84 96         183 return;
85             }
86              
87             sub _displayable {
88 96     96   122 my $self = shift;
89 96         123 my $errorcode = shift;
90              
91 96         134 my $directives = $self->{_directives};
92 96 100       194 if ( not defined $directives->{$errorcode} ) {
93 87         201 return 1;
94             }
95             else {
96 9         16 return $directives->{$errorcode};
97             }
98             }
99              
100             sub _start_document {
101 47     47   403 return;
102             }
103              
104             sub _end_document {
105 44     44   118 my ($self,$line,$column) = @_;
106              
107 44         232 for my $tag ( sort keys %isRequired ) {
108 176 100       391 if ( !$self->{_first_seen}->{$tag} ) {
109 29         43 $self->gripe( 'doc-tag-required', tag => $tag );
110             }
111             }
112              
113 44         130 return;
114             }
115              
116             sub _start {
117 528     528   1091 my ($self,$tag,$line,$column,@attr) = @_;
118              
119 528         634 $self->{_line} = $line;
120 528         570 $self->{_column} = $column;
121              
122 528         744 my $validattr = $isKnownAttribute{ $tag };
123 528 100       772 if ( $validattr ) {
124 525         507 my %seen;
125 525         539 my $i = 0;
126 525         949 while ( $i < @attr ) {
127 630         996 my ($attr,$val) = @attr[$i++,$i++];
128 630 100       1052 if ( $seen{$attr}++ ) {
129 1         3 $self->gripe( 'attr-repeated', tag => $tag, attr => $attr );
130             }
131              
132 630 100       865 if ( !$validattr->{$attr} ) {
133 4         11 $self->gripe( 'attr-unknown', tag => $tag, attr => $attr );
134             }
135              
136 630         754 $self->_entity($val, 'attr');
137             } # while attribs
138             }
139             else {
140 3         14 $self->gripe( 'elem-unknown', tag => $tag );
141             }
142 528 100       1309 $self->_element_push( $tag ) unless $HTML::Tagset::emptyElement{ $tag };
143              
144 528 100       818 if ( my $where = $self->{_first_seen}{$tag} ) {
145 291 100       400 if ( $isNonrepeatable{$tag} ) {
146             $self->gripe( 'elem-nonrepeatable',
147             tag => $tag,
148 1         2 where => HTML::Lint::Error::where( @{$where} )
  1         3  
149             );
150             }
151             }
152             else {
153 237         472 $self->{_first_seen}{$tag} = [$line,$column];
154             }
155              
156             # Call any other overloaded func
157 528         746 my $tagfunc = "_start_$tag";
158 528 100       1706 if ( $self->can($tagfunc) ) {
159 53         116 $self->$tagfunc( $tag, @attr );
160             }
161              
162 528         1735 return;
163             }
164              
165             sub _text {
166 761     761   1219 my ($self,$text) = @_;
167              
168 761         1276 $self->_entity($text, 'text');
169              
170 761         2369 return;
171             }
172              
173             sub _entity {
174 1391     1391   1671 my ($self,$text,$type) = @_;
175              
176 1391 100       1954 if ( not $self->{_entity_lookup} ) {
177 44         5052 my @entities = sort keys %HTML::Entities::entity2char;
178             # Strip his semicolons
179 44         5814 s/;$// for @entities;
180 44         158 $self->{_entity_lookup} = { map { ($_,1) } @entities };
  11132         16185  
181             }
182              
183 1391         3316 while ( $text =~ /([^\x09\x0A\x0D -~])/g ) {
184 4         13 my $bad = $1;
185             $self->gripe(
186             $type . '-use-entity',
187             char => sprintf( '\x%02lX', ord($bad) ),
188 4   66     41 entity => $char2entity{ $bad } || '&#' . ord($bad) . ';',
189             );
190             }
191              
192 1391         2152 while ( $text =~ /&([^ ;]*;?)/g ) {
193 90         223 my $match = $1;
194              
195 90 100       361 if ( $match eq '' ) {
    100          
    100          
    100          
196 4         25 $self->gripe( $type . '-use-entity', char => '&', entity => '&' );
197             }
198             elsif ( $match !~ m/;$/ ) {
199 6 100 100     53 if ( exists $self->{_entity_lookup}->{$match}
      66        
200             || $match =~ m/^#(\d+)$/ || $match =~ m/^#x[\dA-F]+$/i) {
201 5         25 $self->gripe( $type . '-unclosed-entity', entity => "&$match;" );
202             }
203             else {
204 1         5 $self->gripe( $type . '-unknown-entity', entity => "&$match" );
205             }
206             }
207             elsif ( $match =~ m/^#(\d+);$/ ) {
208             # All numeric entities are OK. We used to check that they were in a given range.
209             }
210             elsif ( $match =~ m/^#x([\dA-F]+);$/i ) {
211             # All hex entities OK. We used to check that they were in a given range.
212             }
213             else {
214 65         144 $match =~ s/;$//;
215 65 100       199 if ( !exists $self->{_entity_lookup}->{$match} ) {
216 4         16 $self->gripe( $type . '-unknown-entity', entity => "&$match;" );
217             }
218             }
219             }
220              
221 1391         2199 return;
222             }
223              
224             sub _comment {
225 29     29   95 my ($self,$tagname,$line,$column,$text) = @_;
226              
227             # Look for the html-lint directives
228 29 100       102 if ( $tagname =~ m/^\s*html-lint\s*(.+)\s*$/ ) {
229 14         26 my $text = $1;
230              
231 14         29 my @commands = split( /\s*,\s*/, $text );
232              
233 14         24 for my $command ( @commands ) {
234 15         44 my ($directive,$value) = split( /\s*:\s*/, $command, 2 );
235 15         47 _trim($_) for ($directive,$value);
236              
237 15 100 100     57 if ( ($directive ne 'all') &&
238             ( not exists $HTML::Lint::Error::errors{ $directive } ) ) {
239 1         4 $self->gripe( 'config-unknown-directive',
240             directive => $directive,
241             where => HTML::Lint::Error::where($line,$column)
242             );
243 1         2 next;
244             }
245              
246 14         19 my $normalized_value = _normalize_value( $value );
247 14 100       25 if ( !defined($normalized_value) ) {
248 1         5 $self->gripe( 'config-unknown-value',
249             directive => $directive,
250             value => $value,
251             where => HTML::Lint::Error::where($line,$column)
252             );
253 1         2 next;
254             }
255              
256 13 100       25 if ( $directive eq 'all' ) {
257 3         21 for my $err ( keys %HTML::Lint::Error::errors ) {
258 63         66 $self->_set_directive( $err, $normalized_value );
259             }
260             }
261             else {
262 10         20 $self->_set_directive( $directive, $normalized_value );
263             }
264             }
265             }
266              
267 29         147 return;
268             }
269              
270             sub _set_directive {
271 73     73   64 my $self = shift;
272 73         66 my $which = shift;
273 73         58 my $what = shift;
274              
275 73         81 $self->{_directives}{$which} = $what;
276              
277 73         85 return;
278             }
279              
280              
281             sub _normalize_value {
282 14     14   17 my $what = shift;
283              
284 14         17 $what = _trim( $what );
285 14 100 100     68 return 1 if $what eq '1' || $what eq 'on' || $what eq 'true';
      100        
286 9 100 100     33 return 0 if $what eq '0' || $what eq 'off' || $what eq 'false';
      100        
287 1         2 return undef;
288             }
289              
290             sub _trim {
291 44     44   61 $_[0] =~ s/^\s+//;
292 44         71 $_[0] =~ s/\s+$//;
293              
294 44         56 return $_[0];
295             }
296              
297             sub _end { ## no critic ( Subroutines::ProhibitManyArgs ) I have no choice in what these args are.
298 391     391   1281 my ($self,$tag,$line,$column,$tokenpos,@attr) = @_;
299              
300 391         482 $self->{_line} = $line;
301 391         425 $self->{_column} = $column;
302              
303 391 100       705 if ( !$tokenpos ) {
    100          
304             # This is a dummy end event for something like .
305             # Do nothing.
306             }
307             elsif ( $HTML::Tagset::emptyElement{ $tag } ) {
308 1         3 $self->gripe( 'elem-empty-but-closed', tag => $tag );
309             }
310             else {
311 378 100       583 if ( $self->_in_context($tag) ) {
312 374         541 my @leftovers = $self->_element_pop_back_to($tag);
313 374         594 for ( @leftovers ) {
314 26         34 my ($tag,$line,$col) = @{$_};
  26         50  
315             $self->gripe( 'elem-unclosed', tag => $tag,
316             where => HTML::Lint::Error::where($line,$col) )
317 26 100       110 unless $HTML::Tagset::optionalEndTag{$tag};
318             } # for
319             }
320             else {
321 4         11 $self->gripe( 'elem-unopened', tag => $tag );
322             }
323             } # is empty element
324              
325             # Call any other overloaded func
326 391         576 my $tagfunc = "_end_$tag";
327 391 50       1197 if ( $self->can($tagfunc) ) {
328 0         0 $self->$tagfunc( $tag, $line );
329             }
330              
331 391         1050 return;
332             }
333              
334             sub _element_push {
335 401     401   446 my $self = shift;
336 401         571 for ( @_ ) {
337 401         375 push( @{$self->{_stack}}, [$_,$self->{_line},$self->{_column}] );
  401         1008  
338             } # while
339              
340 401         472 return;
341             }
342              
343             sub _find_tag_in_stack {
344 752     752   720 my $self = shift;
345 752         722 my $tag = shift;
346 752         757 my $stack = $self->{_stack};
347              
348 752         646 my $offset = @{$stack} - 1;
  752         873  
349 752         1047 while ( $offset >= 0 ) {
350 808 100       1125 if ( $stack->[$offset][0] eq $tag ) {
351 748         1137 return $offset;
352             }
353 60         100 --$offset;
354             } # while
355              
356 4         5 return;
357             }
358              
359             sub _element_pop_back_to {
360 374     374   390 my $self = shift;
361 374         375 my $tag = shift;
362              
363 374 100       435 my $offset = $self->_find_tag_in_stack($tag) or return;
364              
365 330         352 my @leftovers = splice( @{$self->{_stack}}, $offset + 1 );
  330         527  
366 330         332 pop @{$self->{_stack}};
  330         348  
367              
368 330         527 return @leftovers;
369             }
370              
371             sub _in_context {
372 378     378   381 my $self = shift;
373 378         402 my $tag = shift;
374              
375 378         513 my $offset = $self->_find_tag_in_stack($tag);
376 378         666 return defined $offset;
377             }
378              
379             # Overridden tag-specific stuff
380             sub _start_img { ## no critic ( Subroutines::ProhibitUnusedPrivateSubroutines ) # Called by parser based on tag name.
381 43     43   120 my ($self,$tag,%attr) = @_;
382              
383 43         110 my ($h,$w,$src) = @attr{qw( height width src )};
384 43 100 66     116 if ( defined $h && defined $w ) {
385             # Check sizes
386             }
387             else {
388 7         36 $self->gripe( 'elem-img-sizes-missing', src=>$src );
389             }
390 43 100       65 if ( not defined $attr{alt} ) {
391 8         15 $self->gripe( 'elem-img-alt-missing', src=>$src );
392             }
393              
394 43         66 return;
395             }
396              
397             sub _start_input { ## no critic ( Subroutines::ProhibitUnusedPrivateSubroutines ) # Called by parser based on tag name.
398 10     10   25 my ($self,$tag,%attr) = @_;
399              
400 10         20 my ($type,$alt) = @attr{qw( type alt )};
401 10 100 66     34 if ( defined($type) && (lc($type) eq 'image') ) {
402 9         15 my $ok = defined($alt);
403 9 100       13 if ( $ok ) {
404 5         9 $alt =~ s/^ +//;
405 5         9 $alt =~ s/ +$//;
406 5         9 $ok = ($alt ne '');
407             }
408 9 100       15 if ( !$ok ) {
409 6         44 my $name = $attr{name};
410 6 100       17 $name = '' unless defined $name;
411 6         10 $self->gripe( 'elem-input-alt-missing', name => $name );
412             }
413             }
414              
415 10         15 return;
416             }
417              
418             1;