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   1275 use strict;
  2         11  
  2         60  
4 2     2   10 use warnings;
  2         4  
  2         55  
5              
6 2     2   997 use parent qw{ HTML::Parser };
  2         634  
  2         10  
7              
8             our $VERSION = '0.304_01';
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 8424 my ( $class, %arg ) = @_;
18 3         8 my $classic = delete $arg{classic};
19 3         31 my $self = $class->SUPER::new( %arg );
20 3 50       256 $self->{ATTR}{classic} = defined $classic ? $classic : $CLASSIC;
21 3         10 return $self;
22             }
23              
24             sub classic
25             {
26 1     1 1 7 my ( $self ) = @_;
27 1         6 return $self->{ATTR}{classic};
28             }
29              
30             sub start
31             {
32             # my ($self, $tag, $attr, $attrseq, $origtext) = @_;
33 85     85 1 185 my ($self, $tag, $attr, undef, $origtext) = @_;
34              
35 85         130 $tag = lc($tag);
36              
37             # Store the incoming details in the current 'object'.
38 85 100       234 if ($tag eq 'table') {
    100          
    100          
    100          
    100          
39 6         9 my $table = $attr;
40 6         17 push @{ $self->{STORE}{stack} }, {
41 6         11 map { $_ => $self->{STORE}{$_} } @stacked };
  18         60  
42 6         13 push @{$self->{STORE}->{tables}}, $table;
  6         18  
43 6         11 $self->{STORE}->{current_table} = $table;
44 6         9 $self->{STORE}->{current_row} = undef;
45 6         11 $self->{STORE}->{current_element} = undef;
46              
47             } elsif ($tag eq 'th') {
48 8         13 my $th = $attr;
49 8         11 push @{$self->{STORE}->{current_table}->{headers}}, $th;
  8         18  
50 8 100       19 unless ( $self->{ATTR}{classic} ) {
51 7         10 push @{$self->{STORE}->{current_row}->{cells}}, undef;
  7         15  
52 7         8 push @{$self->{STORE}->{current_row}->{headers}}, $th;
  7         15  
53             }
54 8         24 $self->{STORE}->{current_element} = $th;
55              
56             } elsif ($tag eq 'tr') {
57 20         29 my $tr = $attr;
58 20         29 push @{$self->{STORE}->{current_table}->{rows}}, $tr;
  20         41  
59 20         40 $self->{STORE}->{current_row} = $tr;
60 20         27 $self->{STORE}->{current_element} = $tr;
61              
62             } elsif ($tag eq 'td') {
63 29         34 my $td = $attr;
64 29         42 push @{$self->{STORE}->{current_row}->{cells}}, $td;
  29         70  
65 29 100       61 unless ( $self->{ATTR}{classic} ) {
66 25         36 push @{$self->{STORE}->{current_row}->{headers}}, undef;
  25         46  
67             }
68 29         47 $self->{STORE}->{current_element} = $td;
69              
70             } elsif ($tag eq 'caption') {
71 2         3 my $cap = $attr;
72 2         4 $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         33 my $elem = $self->{STORE}->{current_element};
79 20 100       41 if ($elem) {
80 4 50       8 $self->_debug('TEXT(tag) = ', $origtext) if $DEBUG;
81 4         10 $elem->{data} .= $origtext;
82             }
83              
84             }
85              
86 85 50       152 $self->_debug($origtext) if $DEBUG;
87              
88 85         332 return;
89             }
90              
91              
92              
93             sub text
94             {
95 113     113 1 273 my ($self, $text) = @_;
96 113         187 my $elem = $self->{STORE}->{current_element};
97 113 100       204 if (!$elem) {
98 69         301 return;
99             }
100              
101 44 50       82 $self->_debug('TEXT = ', $text) if $DEBUG;
102 44         96 $elem->{data} .= $text;
103              
104 44         157 return;
105             }
106              
107              
108              
109             sub end
110             {
111 85     85 1 165 my ($self, $tag, $origtext) = @_;
112 85         160 $tag = lc($tag);
113              
114             # Turn off the current object
115 85 100       228 if ($tag eq 'table') {
    100          
    100          
    100          
    100          
116 6   50     8 my $prev = pop @{ $self->{STORE}{stack} } || [];
117 6         28 $self->{STORE}{$_} = $prev->{$_} for @stacked;
118              
119             } elsif ($tag eq 'th') {
120 8         14 $self->{STORE}->{current_element} = undef;
121             } elsif ($tag eq 'tr') {
122 20 100       59 for my $key ( 'cells', $self->{ATTR}{classic} ? () : 'headers' ) {
123 35   100     111 my $data = $self->{STORE}{current_row}{$key} || [];
124 35   100     58 pop @{ $data } while @{ $data } && ! $data->[-1];
  67         196  
  32         54  
125             delete $self->{STORE}{current_row}{$key}
126 35 100       51 unless @{ $data };
  35         89  
127             }
128 20         32 $self->{STORE}->{current_row} = undef;
129 20         31 $self->{STORE}->{current_element} = undef;
130              
131             } elsif ($tag eq 'td') {
132 29         54 $self->{STORE}->{current_element} = undef;
133              
134             } elsif ($tag eq 'caption') {
135 2         5 $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         36 my $elem = $self->{STORE}->{current_element};
141 20 100       40 if ($elem) {
142 4 50       10 $self->_debug('TEXT(tag) = ', $origtext) if $DEBUG;
143 4         8 $elem->{data} .= $origtext;
144             }
145              
146             }
147              
148 85 50       147 $self->_debug($origtext) if $DEBUG;
149              
150 85         293 return;
151             }
152              
153              
154             sub parse
155             {
156 5     5 1 18205 my ($self, $data) = @_;
157              
158 5 100       18 unless ( defined $data ) { # RT 7262
159 1         8 require Carp;
160 1         214 Carp::croak( 'Argument must be defined' );
161             }
162              
163             $self->{STORE} = {
164 4         16 stack => [],
165             };
166              
167 4         44 $self->SUPER::parse($data);
168              
169 4         7 my $tables = $self->{STORE}{tables};
170 4         12 delete $self->{STORE};
171              
172 4         31 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__