File Coverage

blib/lib/HTML/ExtractContent/Util.pm
Criterion Covered Total %
statement 46 55 83.6
branch 1 6 16.6
condition 1 2 50.0
subroutine 17 19 89.4
pod 0 13 0.0
total 65 95 68.4


line stmt bran cond sub pod time code
1             package HTML::ExtractContent::Util;
2 3     3   24646 use strict;
  3         5  
  3         74  
3 3     3   14 use warnings;
  3         6  
  3         73  
4 3     3   905 use utf8;
  3         14  
  3         16  
5              
6             # cpan
7 3     3   2262 use Exporter::Lite;
  3         2016  
  3         26  
8 3     3   2444 use HTML::Entities qw(decode_entities);
  3         25643  
  3         282  
9 3     3   3080 use HTML::Strip ();
  3         18499  
  3         3034  
10              
11             sub strip {
12 113     113 0 351 my $str = shift;
13 113         920 $str =~ s/(^\s+|\s+$)//gs;
14 113         466 return $str;
15             }
16              
17             sub strip_tags {
18 67     67 0 805 my $page = shift;
19 67         207 my $hs = HTML::Strip->new;
20 67         3917 return $hs->parse($page);
21             }
22              
23             sub eliminate_tags {
24 30     30 0 741 my ($page, $tag) = @_;
25 30         714 $page =~ s/<$tag[\s>].*?<\/$tag\s*>//igs;
26 30         111 return $page;
27             }
28              
29             sub eliminate_links {
30 15     15 0 37 return eliminate_tags shift, 'a';
31             }
32              
33             sub eliminate_forms {
34 13     13 0 26 return eliminate_tags shift, 'form';
35             }
36              
37             sub eliminate_br {
38 59     59 0 90 my $page = shift;
39 59         104 $page =~ s/]*>/ /igs;
40 59         123 return $page;
41             }
42              
43             sub eliminate_invisible {
44 0     0 0 0 my $page = shift;
45 0         0 my $patterns = [
46             qr//is,
47             qr/<(script|style|select|noscript)[^>]*>.*?<\/\1\s*>/is,
48             qr/]*(id|class)\s*=\s*['"]?\S*(more|menu|side|navi)\S*["']?[^>]*>/is,
49             ];
50 0         0 for my $pat (@$patterns) {
51 0         0 $page =~ s/$pat//igs;
52             }
53 0         0 return $page;
54             }
55              
56             sub extract_alt {
57 0     0 0 0 my $page = shift;
58 0         0 $page =~ s{
59             # no backgrack or otherwise the time complexity will become O(n^2)
60             ]* \b alt \s* = \s* (?>
61             " ([^"]*) " | ' ([^']*) ' | ([^\s"'<>]+)
62             ) [^>]* >
63             }{
64 0 0       0 defined $1 ? $1 : defined $2 ? $2 : $3
    0          
65             }xigse;
66 0         0 return $page;
67             }
68              
69             sub unescape {
70 59     59 0 1416 my $page = shift;
71 59         244 decode_entities($page);
72             }
73              
74             sub reduce_ws {
75 59     59 0 89 my $page = shift;
76 59         296 $page =~ s/[ \t]+/ /g;
77 59         147 $page =~ s/\n\s*/\n/gs;
78 59         141 return $page;
79             }
80              
81             sub decode {
82 59     59 0 113 return strip (reduce_ws (unescape (strip_tags (eliminate_br shift))));
83             }
84              
85             sub to_text {
86 15     15 0 30 my ($html, $opts) = @_;
87 15   50     65 $opts ||= {};
88 15 50       39 $html = extract_alt $html if $opts->{with_alt};
89 15         27 return decode $html;
90             }
91              
92             sub match_count {
93 40     40 0 145 my ($str, $exp) = @_;
94 40         281 my @list = ($str =~ $exp);
95 40         139 return $#list + 1;
96             }
97              
98             our @EXPORT = qw/strip strip_tags eliminate_tags eliminate_links eliminate_forms eliminate_br eliminate_invisible extract_alt unescape reduce_ws decode to_text match_count/;
99              
100             1;