File Coverage

blib/lib/HTML/TableParser.pm
Criterion Covered Total %
statement 133 142 93.6
branch 52 74 70.2
condition 36 52 69.2
subroutine 13 13 100.0
pod 1 1 100.0
total 235 282 83.3


line stmt bran cond sub pod time code
1             # --8<--8<--8<--8<--
2             #
3             # Copyright (C) 2007 Smithsonian Astrophysical Observatory
4             #
5             # This file is part of HTML-TableParser
6             #
7             # HTML-TableParser is free software: you can redistribute it and/or modify
8             # it under the terms of the GNU General Public License as published by
9             # the Free Software Foundation, either version 3 of the License, or (at
10             # your option) any later version.
11             #
12             # This program is distributed in the hope that it will be useful,
13             # but WITHOUT ANY WARRANTY; without even the implied warranty of
14             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15             # GNU General Public License for more details.
16             #
17             # You should have received a copy of the GNU General Public License
18             # along with this program. If not, see .
19             #
20             # -->8-->8-->8-->8--
21              
22             package HTML::TableParser;
23              
24             require 5.8.1;
25 8     8   133086 use strict;
  8         15  
  8         216  
26 8     8   32 use warnings;
  8         10  
  8         232  
27              
28 8     8   32 use Carp;
  8         13  
  8         538  
29 8     8   4316 use HTML::Parser;
  8         41926  
  8         281  
30              
31 8     8   3507 use HTML::TableParser::Table;
  8         12  
  8         12670  
32              
33             ## no critic ( ProhibitAccessOfPrivateData )
34              
35              
36             our @ISA = qw(HTML::Parser);
37              
38             our $VERSION = '0.41';
39              
40             # Preloaded methods go here.
41              
42             our %Attr = ( Trim => 0,
43             Decode => 1,
44             Chomp => 0,
45             MultiMatch => 0,
46             DecodeNBSP => 0,
47             );
48             our @Attr = keys %Attr;
49              
50             our $Verbose = 0;
51              
52             sub new
53             {
54 93     93 1 6589 my $class = shift;
55              
56 93         127 my $reqs = shift;
57              
58 93         541 my $self = $class->SUPER::new
59             (
60             api_version => 3,
61             unbroken_text => 1,
62             start_h => [ '_start', 'self, tagname, attr, line' ],
63             end_h => [ '_end', 'self, tagname, attr, line' ],
64             );
65              
66 93 50 33     4804 croak( __PACKAGE__, ": must specify a table request" )
67             unless defined $reqs and 'ARRAY' eq ref $reqs;
68              
69 93   100     267 my $attr = shift || {};
70              
71 93         223 my @notvalid = grep { ! exists $Attr{$_} } keys %$attr;
  51         181  
72 93 50       214 croak ( __PACKAGE__, ": Invalid attribute(s): '",
73             join(" ,'", @notvalid ), "'" )
74             if @notvalid;
75              
76 93         475 my %attr = ( %Attr, %$attr );
77              
78 93         276 $self->{reqs} = _tidy_reqs( $reqs, \%attr );
79              
80 93         433 $self->{Tables} = [ HTML::TableParser::Table->new() ];
81              
82             # by default we're not processing anything
83 93         184 $self->_process(0);
84              
85 93         231 $self;
86             }
87              
88              
89             our @ReqAttr = ( qw( cols colre id idre class obj start end
90             hdr row warn udata ),
91             keys %Attr );
92             our %ReqAttr = map { $_ => 1 } @ReqAttr;
93              
94             # convert table requests into something that HTML::TableParser::Table can
95             # handle
96             sub _tidy_reqs
97             {
98 93     93   139 my ( $reqs, $attr ) = @_;
99              
100 93         95 my @reqs;
101              
102 93         99 my $nreq = 0;
103 93         195 for my $req ( @$reqs )
104             {
105 95         101 my %req;
106              
107 95         94 $nreq++;
108              
109 95         255 my @notvalid = grep { ! exists $ReqAttr{$_} } keys %$req;
  493         640  
110 95 50       202 croak (__PACKAGE__, ": table request $nreq: invalid attribute(s): '",
111             join(" ,'", @notvalid ), "'" )
112             if @notvalid;
113              
114 95         109 my $req_id = 0;
115              
116              
117             # parse cols and id the same way
118 95         137 for my $what ( qw( cols id ) )
119             {
120 190         255 $req{$what} = [];
121              
122 190 100 66     744 if ( exists $req->{$what} && defined $req->{$what} )
123             {
124 78         65 my @reqs;
125              
126 78         127 my $ref = ref $req->{$what};
127            
128 78 100 100     381 if ( 'ARRAY' eq $ref )
    50 66        
129             {
130 34         38 @reqs = @{$req->{$what}};
  34         68  
131             }
132             elsif ( 'Regexp' eq $ref ||
133             'CODE' eq $ref ||
134             ! $ref )
135             {
136 44         89 @reqs = ( $req->{$what} );
137             }
138             else
139             {
140 0         0 croak( __PACKAGE__,
141             ": table request $nreq: $what must be a scalar, arrayref, or coderef" );
142             }
143            
144             # now, check that we have legal things in there
145 78         132 my %attr = ();
146              
147 78         111 for my $match ( @reqs )
148             {
149 81         94 my $ref = ref $match;
150 81 50 66     359 croak( __PACKAGE__,
      100        
      66        
151             ": table request $nreq: illegal $what `$match': must be a scalar, regexp, or coderef" )
152             unless defined $match && ! $ref || 'Regexp' eq $ref
153             || 'CODE' eq $ref ;
154              
155 81 100 100     374 if ( ! $ref && $match eq '-' )
156             {
157 1         2 %attr = ( exclude => 1 );
158 1         2 next;
159             }
160              
161 80 100 100     297 if ( ! $ref && $match eq '--' )
162             {
163 1         3 %attr = ( skip => 1 );
164 1         1 next;
165             }
166              
167 79 50 66     263 if ( ! $ref && $match eq '+' )
168             {
169 0         0 %attr = ();
170 0         0 next;
171             }
172              
173 79         93 push @{$req{$what}}, { %attr, match => $match };
  79         230  
174 79         121 %attr = ();
175 79         155 $req_id++;
176             }
177             }
178             }
179              
180             # colre is now obsolete, but keep backwards compatibility
181             # column regular expression match?
182 95 100       202 if ( defined $req->{colre} )
183             {
184 17         20 my $colre;
185              
186 17 50       56 if ( 'ARRAY' eq ref $req->{colre} )
    0          
187             {
188 17         33 $colre = $req->{colre};
189             }
190             elsif ( ! ref $req->{colre} )
191             {
192 0         0 $colre = [ $req->{colre} ];
193             }
194             else
195             {
196 0         0 croak( __PACKAGE__,
197             ": table request $nreq: colre must be a scalar or arrayref" );
198             }
199            
200 17         36 for my $re ( @$colre )
201             {
202 17         27 my $ref = ref $re;
203            
204 17 50 66     54 croak( __PACKAGE__, ": table request $nreq: colre must be a scalar" )
205             unless ! $ref or 'Regexp' eq $ref;
206 17 100       19 push @{$req{cols}}, { include => 1,
  17         216  
207             match => 'Regexp' eq $ref ? $re : qr/$re/ };
208 17         34 $req_id++;
209             }
210             }
211              
212              
213 95 50       188 croak( __PACKAGE__,
214             ": table request $nreq: must specify at least one id method" )
215             unless $req_id;
216              
217             $req{obj} = $req->{obj}
218 95 100       200 if exists $req->{obj};
219              
220             $req{class} = $req->{class}
221 95 100       195 if exists $req->{class};
222              
223 95         159 for my $method ( qw( start end hdr row warn new ) )
224             {
225 570 100 100     2037 if ( exists $req->{$method} && 'CODE' eq ref $req->{$method} )
    100 66        
    50          
226             {
227 310         437 $req{$method} = $req->{$method};
228             }
229              
230             elsif ( exists $req{obj} || exists $req{class})
231             {
232 78 100       84 my $thing = exists $req{obj} ? $req{obj} : $req{class};
233              
234 78 100       77 if ( exists $req->{$method} )
235             {
236 2 50       7 if ( defined $req->{$method} )
237             {
238             croak( __PACKAGE__,
239             ": table request $nreq: can't have object & non-scalar $method" )
240 0 0       0 if ref $req->{$method};
241            
242 0         0 my $call = $req->{$method};
243            
244             croak( __PACKAGE__,
245             ": table request $nreq: class doesn't have method $call" )
246 0 0 0     0 if ( exists $req->{obj} && ! $req->{obj}->can( $call ) )
      0        
247             || !UNIVERSAL::can( $thing, $call );
248             }
249            
250             # if $req->{$method} is undef, user must have explicitly
251             # set it so, which is a signal to NOT call that method.
252             }
253             else
254             {
255 76 100       259 $req{$method} = $method
256             if UNIVERSAL::can( $thing, $method );
257             }
258             }
259             elsif( exists $req->{$method} )
260             {
261 0         0 croak( __PACKAGE__, ": invalid callback for $method" );
262             }
263             }
264              
265             # last minute cleanups for things that don't fit in the above loop
266             croak( __PACKAGE__, ": must specify valid constructor for class $req->{class}" )
267 95 50 66     234 if exists $req{class} && ! exists $req{new};
268              
269              
270 95         157 $req{udata} = undef;
271 95 100       195 $req{udata} = exists $req->{udata} ? $req->{udata} : undef;
272              
273 95         179 $req{match} = 0;
274              
275 95         298 @req{@Attr} = @Attr{@Attr};
276              
277             $req{$_} = $attr->{$_}
278 95         153 foreach grep { defined $attr->{$_} } @Attr;
  475         737  
279              
280             $req{$_} = $req->{$_}
281 95         132 foreach grep { defined $req->{$_} } @Attr;
  475         495  
282              
283 95         244 push @reqs, \%req;
284             }
285              
286 93         193 \@reqs;
287             }
288              
289              
290             sub _process
291             {
292 337     337   349 my ($self, $state) = @_;
293              
294 337   100     919 my $ostate = $self->{process} || 0;
295              
296 337 100       450 if ( $state )
297             {
298 123         470 $self->report_tags( qw( table th td tr ) );
299 123         556 $self->handler( 'text' => '_text', 'self, text, line' );
300             }
301              
302             else
303             {
304 214         675 $self->report_tags( qw( table ) );
305 214         612 $self->handler( 'text' => '' );
306             }
307              
308 337         347 $self->{process} = $state;
309 337         736 $ostate;
310             }
311              
312              
313             our %trans = ( tr => 'row',
314             th => 'header',
315             td => 'column' );
316              
317             sub _start
318             {
319 53261     53261   44738 my $self = shift;
320 53261         33293 my $tagname = shift;
321              
322 53261 50       64562 print STDERR __PACKAGE__, "::start : $_[1] : $tagname \n"
323             if $HTML::TableParser::Verbose;
324              
325 53261 100       54418 if ( 'table' eq $tagname )
326             {
327 122         269 $self->_start_table( @_ );
328             }
329              
330             else
331             {
332 53139         48520 my $method = 'start_' . $trans{$tagname};
333              
334 53139         90912 $self->{Tables}[-1]->$method(@_);
335             }
336             }
337              
338              
339             sub _end
340             {
341 9954     9954   8750 my $self = shift;
342 9954         6543 my $tagname = shift;
343              
344 9954 50       12402 print STDERR __PACKAGE__, "::_end : $_[1]: $tagname \n"
345             if $HTML::TableParser::Verbose;
346              
347 9954 100       10241 if ( 'table' eq $tagname )
348             {
349 123         288 $self->_end_table( @_ );
350             }
351              
352             else
353             {
354 9831         9629 my $method = 'end_' . $trans{$tagname};
355              
356 9831         17222 $self->{Tables}[-1]->$method(@_);
357             }
358             }
359              
360              
361             sub _start_table
362             {
363 122     122   151 my ( $self, $attr, $line ) = @_;
364              
365 122         162 my $otbl = $self->{Tables}[-1];
366              
367             my $tbl = HTML::TableParser::Table->new( $self,
368             $self->{Tables}[-1]->ids,
369 122         344 $self->{reqs}, $line );
370              
371 122 50       271 print STDERR __PACKAGE__, "::_start_table : $tbl->{id}\n"
372             if $HTML::TableParser::Verbose;
373              
374 122         265 $self->_process( $tbl->process );
375              
376 122         101 push @{$self->{Tables}}, $tbl;
  122         970  
377             }
378              
379              
380             sub _end_table
381             {
382 123     123   144 my ( $self, $attr, $line ) = @_;
383              
384              
385 123         114 my $tbl = pop @{$self->{Tables}};
  123         198  
386              
387 123 50       250 print STDERR __PACKAGE__, "::_end_table : $tbl->{id}\n"
388             if $HTML::TableParser::Verbose;
389              
390             # the first table in the list is our sentinel table. if we're about
391             # to delete it, it means that we've hit one too many
tags 392             # we delay the croak until after the pop so that the verbose error 393             # message prints something nice. no harm anyway as we're about to 394             # keel over and croak. 395               396             croak( __PACKAGE__, 397             ": $line: unbalanced and
tags; too many tags" ) 398 123 100       118 if 0 == @{$self->{Tables}};   123         457   399               400 122         390 undef $tbl; 401               402 122         3617 $self->_process( $self->{Tables}[-1]->process ); 403             } 404               405               406             sub _text 407             { 408 62098     62098   90590 my ( $self, $text, $line ) = @_; 409               410 62098         94293 $self->{Tables}[-1]->text( $text ); 411             } 412               413               414               415               416             1; 417             __END__