package Contenido::Parser::HTML;
use strict;
use warnings;
use locale;
use base 'Contenido::Parser';
use Contenido::Globals;
use Utils::HTML;
use Data::Dumper;
use utf8;
use Encode;
my @PICNAME = qw ( top menu topmenu home line dot mail razdel button find search srch delivery
head bar label phone bottom bottommenu ico icon post left right service caption arr arrow cart
basket main reply title corner address page buy pix pixel spacer fon welcome razd about back
shapka phones print tel phpBB uho korz korzina raspisanie shop login blank telephone telephones
dealer diler background bg news rss index none btn cards up footer noimage but link excel price
mid graphic busket map girl space catalog bann headline hosting contact schedule redir email
);
my @PICHOST = qw ( top.list.ru addweb.ru adland.ru extreme-dm.com top100.rambler.ru
mypagerank.ru informer.gismeteo.ru lux-bn.com.ua link-txt.com myrating.ljseek.com c.bigmir.net
);
my @PICURL = qw ( rorer counter count ljplus yadro spylog hotlog banner baner ban banners ban
icq mirabilis adriver advertising ad adv ads adview advert weather imho awaps reklama stat cnt
ipz design icons promo cycounter captcha foto_hit header random adcycle rssfeed bansrc
);
my @bad_dimensions = (
{ w => 120, h => 60 },
{ w => 468, h => 60 },
{ w => 120, h => 600 },
{ w => 88, h => 31 },
);
sub new {
my ($proto) = @_;
my $class = ref($proto) || $proto;
my $self = {};
bless $self, $class;
return $self;
}
sub parse {
my ($self, %opts) = @_;
my $content;
if ( $opts{content} ) {
$content = decode('utf-8', delete $opts{content});
delete $self->{content};
} elsif ( $self->{success} || $self->{content} ) {
$content = decode('utf-8', delete $self->{content});
} else {
$self->{success} = 0;
return $self;
}
my $base_url = delete $self->{base_url} || delete $opts{base_url};
my $strip_html = delete $opts{strip_html};
my $debug = $DEBUG;
my $gui = delete $opts{gui};
my $header = decode('utf-8', delete $opts{header});
warn "Header length: ".length($header || '')."\n" if $debug;
my $description = decode('utf-8', delete $opts{description});
warn "Description length: ".length($description || '')."\n" if $debug;
my $minimum = delete $opts{min} || length $description;
my $pre_rools = $self->__parse_rools (delete $opts{parser_pre});
warn Dumper ($pre_rools) if $debug;
my $parse_rools = $self->__parse_rools (delete $opts{parser_run});
warn Dumper ($parse_rools) if $debug;
my $post_rools = $self->__parse_rools (delete $opts{parser_end});
warn Dumper ($post_rools) if $debug;
# warn "Experimental. Debug!!!\n" if $debug;
if ( ref $pre_rools eq 'ARRAY' ) {
my @sets = grep { $_->{command} eq 'set' } @$pre_rools;
foreach my $set ( @sets ) {
if ( $set->{condition}{param} eq 'min' || $set->{condition}{param} eq 'minimum' ) {
my $value = $set->{condition}{value};
unless ( $value =~ /\D/ ) {
if ( $set->{subcommand} eq 'limit' ) {
$minimum = $minimum && $minimum > int($value) ? int($value) : $minimum ? $minimum : int($value);
} else {
$minimum = int($value);
}
}
}
if ( $set->{condition}{param} eq 'description' && $set->{condition}{value} eq 'header' ) {
$description = $header;
}
}
}
$minimum ||= 300;
warn "Tag cleaning...\n" if $debug;
$self->__clean_tags (\$content, $pre_rools);
$content =~ s/>\s+</></sgi;
warn "Image cleaning...\n" if $debug;
$self->__clean_img (\$content);
warn "Empty div cleaning...\n" if $debug;
while ( $self->__clean_empty_div (\$content) ) {}
warn "Make tree...\n" if $debug;
my ($tree, $shortcuts) = $self->__make_tree (\$content, $parse_rools, $debug);
$self->__extract_img ($shortcuts, $base_url, $debug);
$self->__extract_headers ($shortcuts, $header, $debug);
warn "Getting big texts (min=$minimum)...\n" if $debug;
my $chosen = $self->__dig_big_texts (
structure => $shortcuts,
min => $minimum,
ref $parse_rools eq 'ARRAY' && @$parse_rools ? (rools => $parse_rools) : (),
debug => $debug );
unless ( ref $chosen eq 'ARRAY' && @$chosen ) {
$self->{error_message} = 'Nothing was found at all!!! Check your MINIMUM value';
return $self->is_success(0) unless $gui;
}
if ( $description ) {
my @use_rools = grep { $_->{command} eq 'use' && $_->{subcommand} eq 'element' } @$parse_rools if ref $parse_rools eq 'ARRAY';
$chosen = $self->__check_description ($chosen, $description, $debug) unless @use_rools;
}
unless ( ref $chosen eq 'ARRAY' && @$chosen ) {
$self->{error_message} = 'I didn\'t find any valuable text';
return $self->is_success(0) unless $gui;
}
if ( scalar @$chosen > 1 ) {
$chosen = $self->__check_headers ($chosen, $header, $debug);
}
unless ( ref $chosen eq 'ARRAY' && @$chosen ) {
$self->{error_message} = 'I didn\'t find any valuable text';
return $self->is_success(0) unless $gui;
}
$self->__strip_html (
chosen => $chosen,
header => $header,
ref $post_rools eq 'ARRAY' && @$post_rools ? (rools => $post_rools) : (),
debug => $debug
);
if ( ref $parse_rools eq 'ARRAY' ) {
my ($glue) = grep { $_->{command} eq 'glue' } @$parse_rools;
$self->__glue ( $chosen, $glue, $debug ) if ref $glue;
}
warn "Getting images...\n" if $debug;
my $images = $self->__get_images (
structure => $shortcuts,
chosen => $chosen->[0],
base_url => $base_url,
ref $parse_rools eq 'ARRAY' && @$parse_rools ? (rools => $parse_rools) : (),
debug => $debug,
);
if ( ref $images eq 'ARRAY' && @$images ) {
$self->{images} = $images;
$self->{image} = $images->[0];
}
if ( $gui ) {
if ( ref $chosen eq 'ARRAY' ) {
foreach my $elem ( @$chosen ) {
$self->__post_rool ($elem, $post_rools, $description);
}
}
$self->{text} = ref $chosen eq 'ARRAY' ? $chosen->[0] : $chosen;
# $self->{html} = $content;
# $self->{tree} = $shortcuts;
$self->{tree} = $tree;
$self->{chosen} = $chosen;
} else {
$self->__post_rool ($chosen->[0], $post_rools, $description);
$self->{text} = Contenido::Parser::Util::text_cleanup($chosen->[0]->{text});
$self->{chosen} = $chosen;
map { $_->{parent} = undef } @$chosen if ref $chosen eq 'ARRAY';
$tree = undef;
foreach my $key ( keys %$shortcuts ) {
delete $shortcuts->{$key};
}
$shortcuts = undef;
$content = undef;
}
return $self->is_success(1);
}
sub __clean_tags {
my ($self, $content, $rools) = @_;
my @cut_rools;
if ( ref $rools eq 'ARRAY' && @$rools) {
@cut_rools = grep { $_->{command} eq 'dont' && $_->{subcommand} eq 'cut' } @$rools;
}
my @clean_off_rools;
if ( ref $rools eq 'ARRAY' && @$rools) {
@clean_off_rools = grep { $_->{command} eq 'clean' && $_->{subcommand} eq 'off' } @$rools;
}
$$content =~ s/<!DOCTYPE(.*?)>//sgi;
$$content =~ s/<!--(.*?)-->//sgi;
$$content =~ s/<script(.*?)<\/script>//sgi;
$$content =~ s/<hr(.*?)>//sgi;
$$content =~ s/<noscript(.*?)<\/noscript>//sgi;
$$content =~ s/<iframe(.*?)<\/iframe>//sgi;
unless ( grep { $_->{condition}{param} eq 'tag' && $_->{condition}{value} eq 'noindex' } @cut_rools ) {
$$content =~ s/<noindex(.*?)<\/noindex>//sgi;
} else {
$$content =~ s/<\/?noindex(.*?)>//sgi;
}
$$content =~ s/<object(.*?)<\/object>//sgi;
$$content =~ s/<embed(.*?)<\/embed>//sgi;
$$content =~ s/<style(.*?)<\/style>//sgi;
if ( grep { $_->{condition}{param} eq 'tag' && $_->{condition}{value} eq 'form' } @cut_rools ) {
$$content =~ s/<select(.*?)<\/select([^>]*?)>//sgi;
$$content =~ s/<textarea(.*?)<\/textarea([^>]*?)>//sgi;
$$content =~ s/<input([^>]*?)>//sgi;
} else {
$$content =~ s/<form(.*?)<\/form>//sgi;
$$content =~ s/<textarea(.*?)<\/textarea([^>]*?)>//sgi;
$$content =~ s/<select(.*?)<\/select([^>]*?)>//sgi;
}
foreach my $rool ( @clean_off_rools ) {
next unless $rool->{condition}{param} eq 'tag';
my $tag = $rool->{condition}{value};
$$content =~ s/<$tag(.*?)<\/$tag>//sgi;
}
$$content =~ s/<head(.*?)<\/head>//sgi;
$$content =~ s/\ style="(.*?)"//sgi;
$$content =~ s/<\/?span(.*?)>//sgi;
$$content =~ s/<\/?font(.*?)>//sgi;
$$content =~ s/<br(.*?)>/\n/sgi;
$$content =~ s/<link(.*?)>//sgi;
$$content =~ s/<spacer(.*?)>//sgi;
$$content =~ s/<\!\?(.*?)\?>//sgi;
# $$content =~ s/<a\s*?(.*?)>/\n/sgi;
$$content =~ s/<\/p\s*>//sgi;
# $$content =~ s/<\/a\s*>//sgi;
$$content =~ s/<p\s*(.*?)>/\n\n/sgi;
$$content =~ s/onclick="(.*?)"//sgi;
$$content =~ s/onload="(.*?)"//sgi;
}
sub __clean_img {
my ($self, $content) = @_;
my @garbage;
my $i = 1;
while ( $$content =~ /(<img.*?>)/sgi ) {
my $img = $1;
my $src;
if ( $img =~ /src=([^\x20|^>]+)/i ) {
$src = $1;
}
my ($w, $h);
if ( $img =~ /width\s*=\s*["'](\d+)/i || $img =~ /width\s*=\s*(\d+)/i ) {
$w = $1;
}
if ( $img =~ /height\s*=\s*["'](\d+)/i || $img =~ /height\s*=\s*(\d+)/i ) {
$h = $1;
}
my $delim = 0;
if ( $w && $h ) {
foreach my $pair ( @bad_dimensions ) {
if ($w == $pair->{w} && $h == $pair->{h}) {
$delim = 10;
last;
}
}
$delim = ( $w >= $h ? $w : $h ) / ( $w >= $h ? $h : $w ) unless $delim;
}
my $bad_name = __check_img_name ( $src );
if ( $bad_name || ($w && $w < 80) || ($h && $h < 80) || ( $w && $h && ($delim > 2.5) ) ) {
# warn "Bad name: [$src]\n";
push @garbage, $src;
}
}
foreach my $src (@garbage) {
$src =~ s|([*+?()/\\\$\[\]])|\\$1|sg;
$$content =~ s/<img([^>]*?)src=$src([^>]+)>//si;
}
}
sub __check_img_name {
my $name = shift;
my $test = $1 if $name =~ /\/([^\/]+)$/;
if ( $test && ($test =~ /\d+[x-]\d+/ || $test =~ /\.gif$/i) ) {
return 1;
}
foreach my $word ( @PICNAME ) {
if ( $test && ($test =~ /^$word/si || $test =~ /[^a-z]$word[^a-z]/si) ) {
return 1;
}
}
foreach my $word ( @PICURL ) {
if ( $name =~ /^$word/si || $name =~ /[^a-z]$word[^a-z]/si ) {
return 1;
}
}
foreach my $word ( @PICHOST ) {
if ( index (lc($name), $word) >= 0 ) {
return 1;
}
}
return 0;
}
sub __clean_empty_div {
my ($self, $content) = @_;
my $i = 0;
while ( $$content =~ s/(<div[^>]*?><\/div\s*>)//sgi ) {
$i++;
}
return $i;
}
sub __make_tree {
my ($self, $content, $rools, $debug) = @_;
my @elems = split (//,$$content);
my @collaborate;
if ( ref $rools eq 'ARRAY' && @$rools) {
@collaborate = grep { $_->{command} eq 'collaborate' } @$rools;
}
my %hierarchy = ( div => 0, td => 1, tr => 2, table => 3, body => 4, html => 5 );
my $id = 1;
my $level = 0;
my %tree = (
root => {
id => $id++,
text => '',
type => 'root',
children=> [],
parent => undef,
level => $level,
},
);
my @stack;
my %elem_hash = ( 1 => $tree{root} );
my $current = $tree{root};
my $previous;
while ( @elems ) {
if ($elems[0] =~ /[\ \t]/ && !$current){
shift @elems;
next;
}
if ( $elems[0] eq '<' && $elems[1] =~ /[a-zA-Z]/ ) {
my $tag = $self->__try_tag (\@elems);
if ( ref $tag && $tag->{type} eq 'text' ) {
my $last_text_tag = ref $current->{children} eq 'ARRAY' && @{$current->{children}} && $current->{children}->[-1]->{type} eq 'text' ? $current->{children}->[-1] : undef;
if ( ref $last_text_tag ) {
$last_text_tag->{text} .= $tag->{content};
$last_text_tag->{count} += $tag->{count};
} else {
$last_text_tag = $tag;
$last_text_tag->{id} = $id++;
$last_text_tag->{type} = 'text';
$last_text_tag->{parent} = $current;
$last_text_tag->{level} = $level+1;
$last_text_tag->{text} = $tag->{content};
$elem_hash{$last_text_tag->{id}} = $last_text_tag;
push @{$current->{children}}, $last_text_tag;
$current->{text_count}++;
}
$current->{text_value} += $tag->{count};
splice @elems, 0, $tag->{count};
# warn "Tag opened. Next text: [".join('',$elems[0..10])."]\n";
} elsif ( ref $tag ) {
if ( ($current->{type} eq 'td' || $current->{type} eq 'tr' ) && $tag->{type} eq 'tr' ) {
# warn "!!!! Error: HTML validation. ID=[$current->{id}]. Stack rollback till table begin... !!!!\n" if $debug;
do {
$current = pop @stack;
$level = $current->{level};
# warn "New current type: /$current->{type}. ID = $current->{id}. Level: $level. Stack depth: ".scalar(@stack)."\n";
} while ( ($current->{type} !~ /table|body|html/) && scalar @stack );
}
if ( $current->{type} eq 'table' && $tag->{type} eq 'table' ) {
# warn "!!!! Error: HTML validation. ID=[$current->{id}]. Stack rollback, previous table(s) will forced to be closed... !!!!\n" if $debug;
do {
$current = pop @stack;
$level = $current->{level};
# warn "New current type: /$current->{type}. ID = $current->{id}. Level: $level. Stack depth: ".scalar(@stack)."\n";
} while ( ($current->{type} eq "table") && scalar @stack );
}
$tag->{id} = $id++;
$tag->{children} = [];
$tag->{text_count} = 0;
$tag->{parent} = $current;
$tag->{level} = ++$level;
$elem_hash{$tag->{id}} = $tag;
push @{$current->{children}}, $tag;
push @stack, $current;
# warn "Open type: $tag->{type}. ID=[$tag->{id}]. Name: ".($tag->{params}{name}||'').". Class: ".($tag->{params}{class}||'').". Level: $tag->{level}. Stack depth: ".scalar(@stack)."\n";
$current = $tag;
splice @elems, 0, $tag->{count};
} else {
# warn "!!!! Error: HTML analyse. Job broken... !!!!\n" if $debug;
last;
}
} elsif ( $elems[0] eq '<' && $elems[1] =~ /\// ) {
my $tag = $self->__try_end (\@elems);
if ( ref $tag && $tag->{type} eq 'text' ) {
my $last_text_tag = ref $current->{children} eq 'ARRAY' && @{$current->{children}} && $current->{children}->[-1]->{type} eq 'text' ? $current->{children}->[-1] : undef;
if ( ref $last_text_tag ) {
$last_text_tag->{text} .= $tag->{content};
$last_text_tag->{count} += $tag->{count};
} else {
$last_text_tag = $tag;
$last_text_tag->{id} = $id++;
$last_text_tag->{type} = 'text';
$last_text_tag->{parent} = $current;
$last_text_tag->{text} = $tag->{content};
$last_text_tag->{level} = $level+1;
$elem_hash{$last_text_tag->{id}} = $last_text_tag;
push @{$current->{children}}, $last_text_tag;
$current->{text_count}++;
}
$current->{text_value} += $tag->{count};
splice @elems, 0, $tag->{count};
} elsif ( ref $tag ) {
if ( $current->{type} ne $tag->{type} ) {
# warn "!!!!Wrong tag type for closing. It's [$tag->{type}]. It must be [$current->{type}]!!!!\n" if $debug;
# warn "Current ID: [$current->{id}]. Text place: [".substr($current->{text}, 0, 20)."]\n";
if ( $hierarchy{$tag->{type}} > $hierarchy{$current->{type}} ) {
do {
$current = pop @stack;
$level = $current->{level};
# warn "New current type: /$current->{type}. Level: $level. Stack depth: ".scalar(@stack)."\n";
} while ( ($current->{type} ne $tag->{type}) && scalar @stack );
$current = pop @stack;
$level = $current->{level};
# warn "Close !the right! type: /$tag->{type}. Level: $level. Stack depth: ".scalar(@stack)."\n" if $debug;
}else{
# warn "Passing by: /$tag->{type}. Level: $level. Stack depth: ".scalar(@stack)."\n" if $debug;
}
} else {
if ( @collaborate ) {
if ( defined $previous && (grep { $current->{type} eq $_->{condition} } @collaborate)
&& $previous->{type} eq $current->{type} && $previous->{level} == $current->{level}
&& $previous->{text} && $current->{text} ) {
$previous->{text} .= ' '.$current->{text};
my $parent = $current->{parent};
splice @{$parent->{children}}, -1, 1;
delete $elem_hash{$current->{id}};
$current = undef;
} elsif ( !defined $previous && $current->{text} ) {
$previous = $current;
} else {
$previous = undef;
}
}
$current = pop @stack;
$level = $current->{level};
# warn "Text place: [".substr($current->{text}, 0, 20)."]\n" if exists $current->{text};
# warn "Close type: /$tag->{type}. Level: $level. Stack depth: ".scalar(@stack)."\n";
}
splice @elems, 0, $tag->{count};
} else {
# warn "!!!! Error: HTML analyse. Job broken... !!!!\n" if $debug;
last;
}
} else {
my $last_text_tag = ref $current->{children} eq 'ARRAY' && @{$current->{children}} && $current->{children}->[-1]->{type} eq 'text' ? $current->{children}->[-1] : undef;
if ( ref $last_text_tag ) {
$last_text_tag->{text} .= shift @elems;
$last_text_tag->{count}++;
} else {
$last_text_tag = {};
$last_text_tag->{text} = shift @elems;
$last_text_tag->{count} = 1;
$last_text_tag->{id} = $id++;
$last_text_tag->{type} = 'text';
$last_text_tag->{parent} = $current;
$last_text_tag->{level} = $level+1;
$elem_hash{$last_text_tag->{id}} = $last_text_tag;
push @{$current->{children}}, $last_text_tag;
$current->{text_count}++;
$current->{text_value} = 0;
}
$current->{text_value}++;
}
}
return (\%tree, \%elem_hash);
}
sub __try_tag {
my ($self, $content) = @_;
my $i = 1;
my %tag;
my $tag = $content->[0];
while ( $i < (scalar @$content - 1) && $content->[$i] ne '<' && $content->[$i] ne '>' ) {
$tag .= $content->[$i];
$i++;
}
if ( $content->[$i] eq '<' || $i >= scalar @$content ) {
return {
type => 'text',
content => $tag,
count => $i,
};
}
$tag .= $content->[$i++];
# warn "TAG: [$tag]\n";
if ( $tag =~ /^<(div|table|tr|td|body|html)\s*(.*)/i ) {
my $val = $1;
if ( $tag =~ /^<($val)\s*(.*)/i ) {
$tag{type} = lc($1);
my $args = $2;
$tag{count} = $i;
my %args;
while ( $tag =~ /([a-zA-z]+)\x20*?=\x20*?"([^"]+)"/g ) {
$args{lc($1)} = $2;
}
while ( $tag =~ /([a-zA-z]+)\x20*?=\x20*?'([^']+)'/g ) {
$args{lc($1)} = $2;
}
while ( $tag =~ /([a-zA-z]+)=(\w+)/g ) {
$args{lc($1)} = $2;
}
foreach my $arg ( qw( name id class width align ) ) {
$tag{params}{$arg} = $args{$arg} if exists $args{$arg};
}
return \%tag;
} else {
return {
type => 'text',
content => $tag,
count => $i,
};
}
} else {
return {
type => 'text',
content => $tag,
count => $i,
};
}
}
sub __try_end {
my ($self, $content) = @_;
my $i = 2;
my %tag;
my $tag = $content->[0].$content->[1];
while ( $content->[$i] ne '<' && $content->[$i] ne '>' && $i < (scalar @$content-1) ) {
$tag .= $content->[$i];
$i++;
}
if ( $content->[$i] eq '<' || $i >= scalar @$content ) {
return {
type => 'text',
content => $tag,
count => $i,
};
}
$tag .= $content->[$i++];
# warn "TAG END: [$tag]\n";
if ( $tag =~ /^<\/(div|table|tr|td|body|html)/i ) {
my $val = $1;
if ( $tag =~ /^<\/($val)[\s>]/i ) {
$tag{type} = lc($1);
$tag{count} = $i;
return \%tag;
} else {
return {
type => 'text',
content => $tag,
count => $i,
};
}
} else {
return {
type => 'text',
content => $tag,
count => $i,
};
}
}
sub __extract_img {
my ($self, $structure, $base_url, $debug) = @_;
return unless ref $structure eq 'HASH';
foreach my $tag ( grep { ref $_ && $_->{type} eq 'text' && $_->{text} } values %$structure ) {
my $text = $tag->{text};
while ( $text =~ /<img (.*?)>/sgi ) {
# warn "Image for extract_img found [$1]. Tag ID: $tag->{id}\n";
my $params = $1;
my $img = {};
if ( $params =~ /src\x20*?=\x20*?["'](.*?)["']/ || $params =~ /src=([^\x20]+)/ ) {
$img->{url} = $1;
$img->{url} =~ s/[\r\t\n\ ]+$//;
$img->{url} =~ s/^[\r\t\n\ ]+//;
$img->{url} = $base_url.'/'.$img->{url} unless $img->{url} =~ /^http:/;
$img->{url} =~ s/\/+/\//sgi;
$img->{url} =~ s/http:\//http:\/\//sgi;
$img->{w} = $1 if $params =~ /width[\D]+(\d+)/;
$img->{h} = $1 if $params =~ /height[\D]+(\d+)/;
$img->{alt} = $1 if $params =~ /alt\x20*?=\x20*?["'](.*?)["']/;
$tag->{images} = [] unless ref $tag->{images} eq 'ARRAY';
push @{ $tag->{images} }, $img;
# warn "Image for extract_img stored [$img->{url}]. Tag ID: $tag->{id}\n";
}
}
$text =~ s/<img (.*?)>//sgi;
$tag->{text} = $text;
$tag->{count} = length ($text);
}
}
sub __extract_headers {
my ($self, $structure, $debug) = @_;
return unless ref $structure eq 'HASH';
foreach my $tag ( grep { ref $_ && $_->{type} eq 'text' && $_->{text} } values %$structure ) {
my $text = $tag->{text};
while ( $text =~ /<h([\d])[^>]*?>([^<]+)<\/h[\d]>/sgi ) {
my $header_level = $1;
my $header_text = $2;
$tag->{headers} = [] unless ref $tag->{headers} eq 'ARRAY';
push @{ $tag->{headers} }, { level => $header_level, text => $header_text };
}
}
}
sub __dig_big_texts {
my ($self, %opts) = @_;
my $structure = exists $opts{structure} ? $opts{structure} : undef;
my $minimum = exists $opts{min} ? $opts{min} : undef;
my $debug = exists $opts{debug} ? $opts{debug} : undef;
my $rools = exists $opts{rools} ? $opts{rools} : undef;
return unless ref $structure eq 'HASH';
my @rools;
if ( ref $rools eq 'ARRAY' && @$rools) {
@rools = grep { $_->{command} eq 'use' && $_->{subcommand} eq 'element' } @$rools;
}
my @exclude_rools;
if ( ref $rools eq 'ARRAY' && @$rools) {
@exclude_rools = grep { $_->{command} eq 'exclude' && $_->{subcommand} eq 'element' } @$rools;
}
my @ret;
foreach my $tag ( sort { $a->{id} <=> $b->{id} } grep { ref $_ && $_->{type} eq 'text' && $_->{text} } values %$structure ) {
next if $self->__exclude_rools($tag->{parent}, \@exclude_rools);
if ( @rools ) {
my $choose = 0;
foreach my $rool ( @rools ) {
my $matched = 1;
foreach my $cond ( @{$rool->{condition}} ) {
unless ( exists $tag->{parent}{params}{$cond->{param}} && $tag->{parent}{params}{$cond->{param}} eq $cond->{value} ) {
$matched = 0;
}
}
$choose ||= $matched;
}
if ( $choose ) {
for ( $tag->{text} ) {
s/^[\t\ \n\r]+//s;
s/[\t\ \n\r]+$//s;
s/[\t\ ]+/\ /sg;
s/\r//sg;
s/\n{2,}/\n\n/sg;
s/\&\\x(\d+)//sgi;
}
my $text = $tag->{text};
$text =~ s/<a.*?href.*?<\/a[^>]*?>//sgi;
$text = Contenido::Parser::Util::strip_html($text);
$tag->{text_weight} = length($text);
if ( length($text) >= $minimum ) {
for ( $tag->{text} ) {
s/<a.*?>//sgi;
s/<\/a.*?>//sgi;
}
push @ret, $tag;
}
}
} else {
for ( $tag->{text} ) {
s/^[\t\ \n\r]+//s;
s/[\t\ \n\r]+$//s;
s/[\t\ ]+/\ /sg;
s/\r//sg;
s/\n{2,}/\n\n/sg;
}
my $text = $tag->{text};
$text =~ s/<a.*?href.*?<\/a[^>]*?>//sgi;
$text = Contenido::Parser::Util::strip_html($text);
$tag->{text_weight} = length($text);
if ( length($text) >= $minimum ) {
for ( $tag->{text} ) {
s/<a.*?>//sgi;
s/<\/a.*?>//sgi;
s/\&\\x(\d+)//sgi;
}
push @ret, $tag;
}
}
}
unless ( @ret ) {
warn "Nothing was found at all!!! Check your ROOLS or MINIMUM value" if $debug;
}
warn "Digging done!\n" if $debug;
return \@ret;
}
sub __check_headers {
my ($self, $chosen, $header, $debug) = @_;
return unless ref $chosen eq 'ARRAY';
unless ( grep { exists $_->{headers} } @$chosen ) {
warn "No headers found\n" if $debug;
return $chosen;
} else {
# @$chosen = grep { exists $_->{headers} } @$chosen;
}
my @ret;
foreach my $unit ( @$chosen ) {
unless ( exists $unit->{headers} && ref $unit->{headers} eq 'ARRAY' ) {
$unit->{header_identity} = 0;
$unit->{header_min_level} = 32768;
next;
}
my @headers = sort { $a->{level} <=> $b->{level} } @{$unit->{headers}};
my $min_level = $headers[0]->{level};
$unit->{header_min_level} = $min_level;
if ( $header ) {
my $coeff = $self->__str_compare( $header, $headers[0]->{text} );
$unit->{header_identity} = $coeff;
}
}
# @ret = sort { $a->{header_min_level} <=> $b->{header_min_level} } @$chosen;
# return \@ret;
return $chosen;
}
sub __check_description {
my ($self, $chosen, $desc, $debug) = @_;
return unless ref $chosen eq 'ARRAY' && $desc;
my @ret;
foreach my $unit ( @$chosen ) {
if ( $desc ) {
my $coeff = $self->__str_compare( $unit->{text}, $desc );
warn "Coeff: [$coeff] to: [$unit->{text}]\n" if $debug;
$unit->{description_identity} = $coeff;
}
}
@ret = sort { $b->{description_identity} <=> $a->{description_identity} } grep { $_->{description_identity} > -0.9 } @$chosen;
return \@ret;
}
# wtf, bastards! how come my code's used here? --ra
# damn, it's not 100% your code already
sub __str_compare {
my ($self, $original, $applicant) = @_;
my $Al = __freq_list($original);
return -1 unless defined $Al;
my $Bl = __freq_list($applicant);
return -1 unless defined $Bl;
my $df = 0;
foreach my $word ( %$Bl ) {
if ( exists $Al->{$word} ) {
$df += $Al->{$word} || 0;
} else {
$df -= $Bl->{$word} || 0;
}
}
return $df;
}
sub __freq_list {
my @d = grep { length($_) > 3 } split /\W/, $_[0];
return undef unless @d;
my $z = 1/scalar(@d); my %l = ();
$l{$_} += $z for @d; \%l;
}
sub __strip_html {
my ($self, %opts) = @_;
return unless ref $opts{chosen} eq 'ARRAY';
my $chosen = $opts{chosen};
my $rooles = $opts{rools};
my $header = $opts{header};
foreach my $unit ( @$chosen ) {
my %tags;
my $headers = $unit->{headers} if exists $unit->{headers};
if ( ref $headers && ref $rooles eq 'ARRAY' && grep { $_->{command} eq 'kill' && $_->{condition}{param} eq 'headers' } @$rooles ) {
if ( grep { $_->{command} eq 'kill' && $_->{condition}{param} eq 'headers' && $_->{condition}{value} eq 'all' } @$rooles ) {
$unit->{text} =~ s/<h(\d)[^>]*>(.*?)<\/h(\d)[^>]*>/\n/sgi;
$unit->{text} =~ s/^[\x20\t\r\n]+//si;
} elsif ( grep { $_->{command} eq 'kill' && $_->{condition}{param} eq 'headers' && $_->{condition}{value} eq 'leading' } @$rooles ) {
while ( $unit->{text} =~ /^<h(\d)[^>]*>(.*?)<\/h(\d)[^>]*>/si ) {
my $hdr = 'h'.$1;
$unit->{text} =~ s/^<$hdr[^>]*>(.*?)<\/$hdr[^>]*>//si;
}
}
}
for ( $unit->{text} ) {
s/></> </sg;
s/([\!\?:.])\s*?<\/h(\d+)(.*?)>/$1 /sgi;
s/<\/h(\d+)(.*?)>/\. /sgi;
s/<h(\d+)(.*?)>/\n/sgi;
s/&/\&/sg;
s/&/\&/sgi;
s/«/«/sg;
s/»/»/sg;
s/£/£/sg;
s/–/–/sg;
s/—/—/sg;
s/…/\.\.\./sg;
s/„/"/sg;
s/“/"/sg;
s/”/"/sg;
s/´/'/sg;
s/ /\n/sg;
s/"/"/sg;
s/ /\ /sgi;
}
# $unit->{text} = HTML::Entities::decode_entities($unit->{text});
# $unit->{text} = Contenido::Parser::Util::strip_html($unit->{text});
for ( $unit->{text} ) {
s/^[\ \t\r\n]+//si;
s/^(\d+)\.(\d+)\.(\d+)//si;
s/^[\ \t\r\n]+//si;
s/^(\d+):(\d+)//si;
s/^[\ \t\r\n]+//si;
}
if ( lc(substr ($unit->{text}, 0, length($header) )) eq lc($header) ) {
substr $unit->{text}, 0, length($header), '';
$unit->{text} =~ s/^[\.\ \t\r\n]+//sgi;
}
$unit->{text} =~ s/[\ \t\r\n]+$//sgi;
}
}
sub __glue {
my ($self, $chosen, $glue, $debug) = @_;
return unless ref $chosen eq 'ARRAY';
my $i = 0;
if ( $glue->{subcommand} eq 'first' || $glue->{subcommand} eq 'all' ) {
my $count = exists $glue->{subcommand} && $glue->{subcommand} eq 'first' ? $glue->{condition} : 32768;
foreach my $unit ( @$chosen ) {
next unless $i++;
if ( $i <= $count ) {
$chosen->[0]->{text} .= "\n\n".$chosen->[$i-1]->{text};
}
}
} elsif ( $glue->{subcommand} eq 'order' && ref $glue->{condition} eq 'ARRAY' ) {
my $text = '';
my $i = 0;
foreach my $pos ( @{ $glue->{condition} } ) {
$text .= ($i++ ? "\n\n" : '').$chosen->[$pos-1]->{text};
}
$chosen->[0]->{text} = $text;
}
}
sub __get_images {
my ($self, %opts) = @_;
my $structure = exists $opts{structure} ? $opts{structure} : undef;
my $chosen = exists $opts{chosen} ? $opts{chosen} : undef;
my $debug = exists $opts{debug} ? $opts{debug} : undef;
my $rools = exists $opts{rools} ? $opts{rools} : undef;
my $base_url = delete $opts{base_url};
return unless ref $chosen && ref $structure;
return if ref $rools eq 'ARRAY' && grep { $_->{command} eq 'image_off' } @$rools;
my @use_rools;
my @exclude_rools;
my $no_validation = 0;
if ( ref $rools eq 'ARRAY' && @$rools) {
@use_rools = grep { $_->{command} eq 'use' && $_->{subcommand} eq 'image' } @$rools;
@exclude_rools = grep { $_->{command} eq 'exclude' && $_->{subcommand} eq 'image' } @$rools;
$no_validation = grep { $_->{command} eq 'dont' && $_->{subcommand} eq 'validate' && $_->{condition}{param} eq 'image' } @$rools;
}
my $image_depth;
if ( ref $rools eq 'ARRAY' && @$rools) {
my @rools = grep { $_->{command} eq 'image' && $_->{subcommand} eq 'depth' } @$rools;
$image_depth = $rools[-1]->{condition} if @rools;
}
my @images;
foreach my $tag ( values %$structure ) {
next unless exists $tag->{images} && ref $tag->{images} eq 'ARRAY';
next if $self->__exclude_rools($tag, \@exclude_rools);
if ( @use_rools ) {
my $choose = 0;
foreach my $rool ( @use_rools ) {
my $matched = 1;
foreach my $cond ( @{$rool->{condition}} ) {
unless ( exists $tag->{params}{$cond->{param}} && $tag->{params}{$cond->{param}} eq $cond->{value} ) {
$matched = 0;
}
}
$matched = 0 if $self->__exclude_rools($tag, \@exclude_rools);
$choose ||= $matched;
}
if ( $choose ) {
my @img = grep { $no_validation || $self->__img_is_valid ($_) } map {
my $img = rchannel::Image->new($_);
$img->src($base_url.($img->src =~ m|^/| ? '' : '/').$img->src) unless $img->src =~ /^http:/;
$img;
} map { {src => $_->{url}, width => $_->{w}, height => $_->{h}, alt => $_->{alt}, title => $_->{alt}} } @{ $tag->{images} };
push @images, @img;
}
} else {
next if ($tag->{level}+1) < $chosen->{parent}{level};
next if $image_depth && ( $tag->{level} > ($chosen->{parent}{level} + $image_depth) );
my $ok = 0;
my $uphops = $tag->{level} > $chosen->{parent}{level} ? 1 : 2;
my $hops = $image_depth ? $image_depth : $tag->{level} - $chosen->{parent}{level} + $uphops;
next if ($hops - $uphops) > 4;
my @img_parents = ($tag->{id});
my $parent = $tag;
for ( 1..$hops ) {
$parent = $parent->{parent};
push @img_parents, $parent->{id};
}
$parent = $chosen->{parent}{parent};
for ( 0..$uphops ) {
if ( grep { $parent->{id} == $_ } @img_parents ) {
$ok = 1;
last;
}
$parent = $parent->{parent};
}
if ( $ok ) {
my @img = grep { $self->__img_is_valid ($_) } map {
my $img = $_;
$img->{src} = $base_url.($img->{src} =~ m|^/| ? '' : '/').$img->{src} unless $img->{src} =~ /^http:/;
$img;
} map { {src => $_->{url}, width => $_->{w}, height => $_->{h}, alt => $_->{alt}, title => $_->{alt}} } @{ $tag->{images} };
push @images, @img;
}
}
}
# warn Dumper (\@images);
if ( @images ) {
return \@images;
} else {
return undef;
}
}
sub __img_is_valid {
my ($self, $img) = @_;
return 1;
if ( $img->check_online ) {
my $delim = 0;
my $w = $img->width;
my $h = $img->height;
if ( $w && $h ) {
foreach my $pair ( @bad_dimensions ) {
if ($w == $pair->{w} && $h == $pair->{h}) {
return undef;
}
}
$delim = ( $w >= $h ? $w : $h ) / ( $w >= $h ? $h : $w ) unless $delim;
if ( $w < 80 || $h < 80 || $delim > 2.5 ) {
return undef;
}
}
} else {
# warn "Image ".$img->src." not found on server";
return undef;
}
return 1;
}
sub __exclude_rools {
my ($self, $tag, $rools) = @_;
return undef unless ref $rools eq 'ARRAY' && @$rools;
my $choose = 0;
foreach my $rool ( @$rools ) {
my $matched = 1;
foreach my $cond ( @{$rool->{condition}} ) {
unless ( exists $tag->{params}{$cond->{param}} && $tag->{params}{$cond->{param}} eq $cond->{value} ) {
$matched = 0;
}
}
$choose ||= $matched;
}
return $choose;
}
sub __parse_rools {
my ($self, $rools) = @_;
return unless $rools;
$rools =~ s/\r//sgi;
my @rools = split /\n/, $rools;
return unless @rools;
my @parsed;
foreach my $rool ( @rools ) {
my %pr;
next if $rool =~ /^#/;
$rool =~ s/[\x20\t]+$//;
$rool =~ s/^[\x20\t]+//;
if ( $rool =~ /^([\w']+)\s+(.*)$/ || $rool =~ /^(\w+)(.*)$/ ) {
$pr{command} = lc($1);
my $params = $2;
if ( $pr{command} eq 'cut' && $params =~ /^(\w+)\s+(.*)$/ ) {
$pr{subcommand} = lc($1); $params = $2;
next unless $pr{subcommand} =~ /^(untill|till|from|off|regex|to)$/;
$params =~ s|([*+?/\\\|])|\\$1|sg unless $pr{subcommand} eq 'regex';
$pr{condition} = $params;
} elsif ( $pr{command} eq 'glue' ) {
if ( $params =~ /^(\w+)\s+(.*)$/ ) {
$pr{subcommand} = $1; $params = $2;
next unless $pr{subcommand} =~ /^(first|all|order)$/;
if ( $pr{subcommand} eq 'order' ) {
my @pars = grep { $_ } map { int($_) } split (/\s*,\s*/,$params);
$pr{condition} = \@pars;
} else {
$pr{condition} = int($1);
}
} elsif ( $params =~ /(\d+)/i ) {
$pr{subcommand} = 'first';
$pr{condition} = int($1);
} else {
$pr{subcommand} = 'all';
}
} elsif ( $pr{command} eq 'trim' ) {
if ( $params =~ /(left|right)/i ) {
$pr{subcommand} = lc($1);
} else {
$pr{subcommand} = 'all';
}
} elsif ( $pr{command} eq 'collaborate' && $params =~ /^(div|td)/i ) {
$pr{condition} = $1;
} elsif ( $pr{command} eq 'image' && $params =~ /^off$/i ) {
$pr{command} = 'image_off';
} elsif ( $pr{command} eq 'image' && $params =~ /^(\w+)\s+(.*)$/si ) {
$pr{subcommand} = lc($1); $params = $2;
next unless $pr{subcommand} =~ /^(depth)$/;
$pr{condition} = $params;
} elsif ( $pr{command} eq 'set' ) {
if ( $params =~ /^(limit)\s+(.*)$/si ) {
$pr{subcommand} = lc($1);
$params = $2;
}
if ( $params =~ /^(\w+)\s+(.*)$/ ) {
$pr{condition} = { param => $1, value => $2 };
} else {
next;
}
} elsif ( $pr{command} eq 'kill' && $params =~ /^(leading|all)\s+(headers)$/ ) {
$pr{command} = 'kill';
$pr{condition} = { param => $2, value => $1 };
} elsif ( $pr{command} eq 'use' && $params =~ /^(title)\s+(as)\s+(description)$/ ) {
$pr{command} = 'set';
$pr{condition} = { param => 'description', value => 'header' };
} elsif ( $pr{command} eq 'use' && $params =~ /^(\w+)\s+(.*)$/ ) {
$pr{subcommand} = $1; $params = $2;
next unless $pr{subcommand} =~ /^(element|elem|image)$/;
$pr{subcommand} = 'element' if $pr{subcommand} =~ /^(element|elem)$/;
my @conditions;
while ( $params =~ /(class|id|name|align)\x20*=\x20*"([^"]+)"/sgi ) {
push @conditions, { param => lc($1), value => $2 }
}
$pr{condition} = \@conditions;
} elsif ( $pr{command} eq 'exclude' && $params =~ /^(\w+)\s+(.*)$/ ) {
$pr{subcommand} = lc($1); $params = $2;
next unless $pr{subcommand} =~ /^(image|elem|element)$/;
$pr{subcommand} = 'element' if $pr{subcommand} =~ /^(element|elem)$/;
my @conditions;
while ( $params =~ /(class|id|name|align)\x20*=\x20*"([^"]+)"/sgi ) {
push @conditions, { param => lc($1), value => $2 }
}
$pr{condition} = \@conditions;
} elsif ( ($pr{command} eq 'dont' || $pr{command} eq "don't") && $params =~ /^(\w+)\s+(.*)$/ ) {
$pr{command} = 'dont';
$pr{subcommand} = lc($1); $params = $2;
next unless $pr{subcommand} =~ /^(cut|validate)$/;
my @conditions;
if ( $params =~ /(tag)\x20*=\x20*"([^"]+)"/sgi ) {
$pr{condition} = { param => lc($1), value => $2 };
} elsif ( $params =~ /(image)/i ) {
$pr{condition} = { param => lc($1) };
} else {
next;
}
} elsif ( $pr{command} eq 'clean' ) {
if ( $params =~ /^(off)\s+(.*)$/ ) {
$pr{subcommand} = lc($1); $params = $2;
}
if ( $params =~ /(tag)\x20*=\x20*"([^"]+)"/sgi ) {
$pr{condition} = { param => lc($1), value => $2 };
} elsif ( $params =~ /(span)/i ) {
$pr{condition} = { param => 'tag', value => lc($1) };
} else {
next;
}
} else {
next;
}
push @parsed, \%pr;
}
}
return ( scalar @parsed ? \@parsed : undef );
}
sub __post_rool {
my ($self, $element, $rools, $description) = @_;
if ( ref $rools eq 'ARRAY' && @$rools ) {
foreach my $rool ( @$rools ) {
if ( $rool->{command} eq 'cut' ) {
my $condition = $rool->{condition};
if ( $rool->{subcommand} eq 'off' ) {
$element->{text} =~ s/$condition//sgi;
} elsif ( $rool->{subcommand} eq 'from' ) {
my $pos = index $element->{text}, $condition;
if ( $pos >= 0 ) {
$element->{text} = substr $element->{text}, 0, $pos;
}
# $element->{text} =~ s/$condition(.*)$//si;
} elsif ( $rool->{subcommand} eq 'to' && $condition eq 'description' && $description ) {
my $str = substr $description, 0, 12;
my $pos = index $element->{text}, $str;
if ( $pos >= 0 ) {
$element->{text} = substr $element->{text}, $pos, -1;
}
} elsif ( $rool->{subcommand} eq 'till' ) {
$element->{text} =~ s/^(.*?)($condition)//si;
} elsif ( $rool->{subcommand} eq 'untill' ) {
$element->{text} =~ s/^(.*?)($condition)/$2/si;
} elsif ( $rool->{subcommand} eq 'regex' ) {
$element->{text} =~ s/$condition//sgi;
}
} elsif ( $rool->{command} eq 'trim' ) {
if ( $rool->{subcommand} eq 'left' ) {
$element->{text} =~ s/^[\x20\xA0\t\n\r]+//sg;
} elsif ( $rool->{subcommand} eq 'right' ) {
$element->{text} =~ s/[\x20\xA0\t\n\r]+$//sg;
} else {
$element->{text} =~ s/^[\x20\xA0\t\n\r]+//sg;
$element->{text} =~ s/[\x20\xA0\t\n\r]+$//sg;
}
}
}
}
}
1;