File Coverage

blib/lib/HTML/TableContentParser.pm
Criterion Covered Total %
statement 97 101 96.0
branch 42 48 87.5
condition 6 7 85.7
subroutine 9 10 90.0
pod 6 6 100.0
total 160 172 93.0


line stmt bran cond sub pod time code
1             package HTML::TableContentParser;
2              
3 2     2   213694 use strict;
  2         3  
  2         74  
4 2     2   7 use warnings;
  2         3  
  2         86  
5              
6 2     2   330 use parent qw{ HTML::Parser };
  2         208  
  2         10  
7              
8             our $VERSION = '0.306';
9              
10             our $CLASSIC = 0;
11             our $DEBUG = 0;
12              
13             my @stacked = qw{ current_table current_row current_element };
14              
15             sub new
16             {
17 3     3 1 218990 my ( $class, %arg ) = @_;
18 3         6 my $classic = delete $arg{classic};
19 3         17 my $self = $class->SUPER::new( %arg );
20 3 50       150 $self->{ATTR}{classic} = defined $classic ? $classic : $CLASSIC;
21 3         7 return $self;
22             }
23              
24             sub classic
25             {
26 1     1 1 4 my ( $self ) = @_;
27 1         5 return $self->{ATTR}{classic};
28             }
29              
30             sub start
31             {
32             # my ($self, $tag, $attr, $attrseq, $origtext) = @_;
33 85     85 1 105 my ($self, $tag, $attr, undef, $origtext) = @_;
34              
35 85         89 $tag = lc($tag);
36              
37             # Store the incoming details in the current 'object'.
38 85 100       148 if ($tag eq 'table') {
    100          
    100          
    100          
    100          
39 6         7 my $table = $attr;
40 6         12 push @{ $self->{STORE}{stack} }, {
41 6         7 map { $_ => $self->{STORE}{$_} } @stacked };
  18         39  
42 6         10 push @{$self->{STORE}->{tables}}, $table;
  6         9  
43 6         17 $self->{STORE}->{current_table} = $table;
44 6         7 $self->{STORE}->{current_row} = undef;
45 6         8 $self->{STORE}->{current_element} = undef;
46              
47             } elsif ($tag eq 'th') {
48 8         8 my $th = $attr;
49 8         7 push @{$self->{STORE}->{current_table}->{headers}}, $th;
  8         14  
50 8 100       12 unless ( $self->{ATTR}{classic} ) {
51 7         6 push @{$self->{STORE}->{current_row}->{cells}}, undef;
  7         10  
52 7         7 push @{$self->{STORE}->{current_row}->{headers}}, $th;
  7         8  
53             }
54 8         10 $self->{STORE}->{current_element} = $th;
55              
56             } elsif ($tag eq 'tr') {
57 20         22 my $tr = $attr;
58 20         18 push @{$self->{STORE}->{current_table}->{rows}}, $tr;
  20         35  
59 20         22 $self->{STORE}->{current_row} = $tr;
60 20         24 $self->{STORE}->{current_element} = $tr;
61              
62             } elsif ($tag eq 'td') {
63 29         28 my $td = $attr;
64 29         21 push @{$self->{STORE}->{current_row}->{cells}}, $td;
  29         56  
65 29 100       38 unless ( $self->{ATTR}{classic} ) {
66 25         25 push @{$self->{STORE}->{current_row}->{headers}}, undef;
  25         31  
67             }
68 29         37 $self->{STORE}->{current_element} = $td;
69              
70             } elsif ($tag eq 'caption') {
71 2         2 my $cap = $attr;
72 2         3 $self->{STORE}->{current_table}->{caption} = $cap;
73 2         3 $self->{STORE}->{current_element} = $cap;
74              
75             } else {
76             ## Found a non-table related tag. Push it into the currently-defined td
77             ## or th (if one exists).
78 20         22 my $elem = $self->{STORE}->{current_element};
79 20 100       30 if ($elem) {
80 4 50       10 $self->_debug('TEXT(tag) = ', $origtext) if $DEBUG;
81 4         7 $elem->{data} .= $origtext;
82             }
83              
84             }
85              
86 85 50       102 $self->_debug($origtext) if $DEBUG;
87              
88 85         184 return;
89             }
90              
91              
92              
93             sub text
94             {
95 113     113 1 162 my ($self, $text) = @_;
96 113         123 my $elem = $self->{STORE}->{current_element};
97 113 100       143 if (!$elem) {
98 69         202 return;
99             }
100              
101 44 50       60 $self->_debug('TEXT = ', $text) if $DEBUG;
102 44         60 $elem->{data} .= $text;
103              
104 44         90 return;
105             }
106              
107              
108              
109             sub end
110             {
111 85     85 1 101 my ($self, $tag, $origtext) = @_;
112 85         89 $tag = lc($tag);
113              
114             # Turn off the current object
115 85 100       176 if ($tag eq 'table') {
    100          
    100          
    100          
    100          
116 6   50     5 my $prev = pop @{ $self->{STORE}{stack} } || [];
117 6         22 $self->{STORE}{$_} = $prev->{$_} for @stacked;
118              
119             } elsif ($tag eq 'th') {
120 8         34 $self->{STORE}->{current_element} = undef;
121             } elsif ($tag eq 'tr') {
122 20 100       32 for my $key ( 'cells', $self->{ATTR}{classic} ? () : 'headers' ) {
123 35   100     54 my $data = $self->{STORE}{current_row}{$key} || [];
124 35   100     34 pop @{ $data } while @{ $data } && ! $data->[-1];
  67         151  
  32         37  
125             delete $self->{STORE}{current_row}{$key}
126 35 100       33 unless @{ $data };
  35         60  
127             }
128 20         25 $self->{STORE}->{current_row} = undef;
129 20         20 $self->{STORE}->{current_element} = undef;
130              
131             } elsif ($tag eq 'td') {
132 29         45 $self->{STORE}->{current_element} = undef;
133              
134             } elsif ($tag eq 'caption') {
135 2         4 $self->{STORE}->{current_element} = undef;
136              
137             } else {
138             ## Found a non-table related close tag. Push it into the currently-defined
139             ## td or th (if one exists).
140 20         21 my $elem = $self->{STORE}->{current_element};
141 20 100       27 if ($elem) {
142 4 50       5 $self->_debug('TEXT(tag) = ', $origtext) if $DEBUG;
143 4         5 $elem->{data} .= $origtext;
144             }
145              
146             }
147              
148 85 50       102 $self->_debug($origtext) if $DEBUG;
149              
150 85         173 return;
151             }
152              
153              
154             sub parse
155             {
156 5     5 1 17737 my ($self, $data) = @_;
157              
158 5 100       15 unless ( defined $data ) { # RT 7262
159 1         5 require Carp;
160 1         168 Carp::croak( 'Argument must be defined' );
161             }
162              
163             $self->{STORE} = {
164 4         12 stack => [],
165             };
166              
167 4         54 $self->SUPER::parse($data);
168              
169 4         7 my $tables = $self->{STORE}{tables};
170 4         6 delete $self->{STORE};
171              
172 4         22 return $tables;
173             }
174              
175              
176              
177              
178             sub _debug
179             {
180 0     0     my ( $self, @args ) = @_;
181 0           my $class = ref($self);
182 0           warn "$class: ", join( '', @args ), "\n";
183 0           return;
184             }
185              
186              
187             1;
188              
189              
190             __END__