File Coverage

blib/lib/HTML/ListScraper.pm

Criterion	Covered	Total	%
statement	139	174	79.8
branch	21	44	47.7
condition	4	6	66.6
subroutine	21	26	80.7
pod	12	12	100.0
total	197	262	75.1

package HTML::ListScraper;

use warnings;
use strict;

use HTML::Parser;
use Class::Generate qw(class);

use HTML::ListScraper::Vat;
use HTML::ListScraper::Book;
use HTML::ListScraper::Sweep;

use vars qw(@ISA);

class 'HTML::ListScraper::Sequence' => {
    len => { type => '$', required => 1, readonly => 1 },
    instances => { type => '@', required => 1 }
};

class 'HTML::ListScraper::Instance' => {
    start => { type => '$', required => 1, readonly => 1 },
    match => { type => '$', required => 1, readonly => 1 },
    score => { type => '$', required => 0, readonly => 1 },
    tags => { type => '@', required => 1 }
};

@ISA = qw(HTML::Parser);

our $VERSION = '0.08';

sub new {
    my $class = shift;

    my $self = $class->SUPER::new(@_);
    bless $self, $class;

    $self->{book} = HTML::ListScraper::Book->new();
    $self->{min_count} = 2;

    $self->handler('start' => 'on_start', 'self, tagname, attr');
    $self->handler('text' => 'on_text', 'self, dtext');
    $self->handler('end' => 'on_end', 'self, tagname');

    return $self;
}

sub min_count {
    my $self = shift;

    if (@_) {
        if ($_[0] < 2) {
	    die "minimal sequence count must be at least 2";
	}

        $self->{min_count} = $_[0];
    }

    return $self->{min_count};
}

sub shapeless {
    my $self = shift;

    if (@_) {
        $self->{book}->shapeless($_[0]);
    }

    return $self->{book}->shapeless;
}

sub is_unclosed_tag {
    my ($self, $name) = @_;

    return $self->{book}->is_unclosed_tag($name);
}

sub get_all_tags {
    my $self = shift;

    return $self->{book}->get_all_tags();
}

sub get_sequences {
    my $self = shift;

    my @sequences;
    my $vat = HTML::ListScraper::Vat->new($self->{book}, $self->{min_count});
    my $foam = $vat->create_sequence;
    if ($foam) {
        foreach my $handle ($foam->get_sequences) {
	    my $occ = $foam->get_occurence($handle);
	    push @sequences, $self->_make_sequence($occ);
	}
    }

    return sort {
        $a->len <=> $b->len;
    } @sequences;
}

sub find_sequences {
    my $self = shift;

    my @sequences;
    my $vat = HTML::ListScraper::Vat->new($self->{book}, $self->{min_count});
    my $foam = $vat->create_sequence;
    if ($foam) {
        foreach my $sign ($foam->get_sequences) {
	    my $occ = $foam->get_occurence($sign);
	    push @sequences, $self->_make_approx_seq($sign, $occ);
	}
    }

    return sort {
        $a->len <=> $b->len;
    } @sequences;
}

sub _get_known_occ {
    my ($self, $needle) = @_;

    my $len = length($needle);

    my $haystack = join '', $self->{book}->get_internal_sequence;

    my $occ = undef;
    my $pos = index($haystack, $needle);
    while ($pos >= 0) {
        if (!defined($occ)) {
	    $occ = HTML::ListScraper::Occurence->new($len, $pos);
	} else {
	    $occ->append_pos($pos);
	}

        $pos = index($haystack, $needle, $pos + $len);
    }

    return $occ;
}

sub get_known_sequence {
    my $self = shift;

    my $len = scalar(@_);
    if ($len < 2) {
        die "need at least 2 items to look for";
    }

    my $needle = '';
    foreach (@_) {
        my $internal = $self->{book}->get_internal_name($_);
	if (!defined($internal)) { # sequence not found if item not found
	    return undef;
	}

	$needle .= $internal;
    }

    my $occ = $self->_get_known_occ($needle);
    return !defined($occ) ? undef : $self->_make_sequence($occ);
}

sub find_known_sequence {
    my $self = shift;

    my $len = scalar(@_);

    if ($len < 2) {
        die "need at least 2 items to look for";
    }

    my @tags = @_;

    my $sign = '';
    foreach (@tags) {
        my $iname = $self->{book}->intern_name($_);
	$sign .= $iname;
    }

    my $occ = $self->_get_known_occ($sign);
    if ($occ) {
        return $self->_make_approx_seq($sign, $occ);
    } else {
	return $self->_make_whole_seq($sign);
    }
}

sub _make_approx_seq {
    my ($self, $sign, $occ) = @_;

    my $len = $occ->len;
    my $edge;
    my @instances;
    foreach my $pos ($occ->positions) {
        my $gap;
	if (!defined($edge)) {
	    $gap = 0;
	} elsif ($pos >= $edge + $len) {
	    $gap = $edge + $len;
	}

	if (defined($gap)) {
	    push @instances,
	        $self->_make_approx_inst($sign, $gap, $pos);

	    my @tags = $self->{book}->get_tags($pos, $len);
	    push @instances,
	        HTML::ListScraper::Instance->new(start => $pos,
		    match => 'exact', tags => \@tags);
	    $edge = $pos;
	}
    }

    if (!defined($edge)) {
        die "no occurence";
    }

    my $iseq = $self->{book}->get_internal_sequence;
    my $end = scalar(@$iseq);
    push @instances,
        $self->_make_approx_inst($sign, $edge + $len, $end);

    return HTML::ListScraper::Sequence->new(len => $len,
        instances => \@instances);
}

sub _make_whole_seq {
    my ($self, $sign) = @_;

    my $iseq = $self->{book}->get_internal_sequence;
    my $end = scalar(@$iseq);
    my @instances = $self->_make_approx_inst($sign, 0, $end);

    my $seq = undef;
    if (scalar(@instances)) {
        $seq = HTML::ListScraper::Sequence->new(len => length($sign),
            instances => \@instances);
    }

    return $seq;
}

sub _make_approx_inst {
    my ($self, $sign, $begin, $end) = @_;

    my $size = $end - $begin;
    if ($size < 2) {
        return ();
    }

    my $sweep = HTML::ListScraper::Sweep->new(
        book => $self->{book}, sign => $sign,
        begin => $begin, end => $end);
    my $dust = $sweep->create_dust;
    my @instances;
    foreach my $align ($dust->get_alignments) {
        my @tags;
	foreach my $pos ($align->positions) {
	    my $t = $self->{book}->get_tag($pos);
	    push @tags, $t;
	}

	my $start = $tags[0]->index;
	push @instances,
	    HTML::ListScraper::Instance->new(start => $start,
		match => 'approx', score => $align->score,
		tags => \@tags);
    }

    return @instances;
}

sub _make_sequence {
    my ($self, $occ) = @_;

    my $len = $occ->len;
    my $edge;
    my @instances;
    foreach my $pos ($occ->positions) {
	if (!defined($edge) || ($pos >= $edge + $len)) {
	    my @tags = $self->{book}->get_tags($pos, $len);
	    push @instances,
	        HTML::ListScraper::Instance->new(start => $pos,
		    match => 'exact', tags => \@tags);
	    $edge = $pos;
	}
    }

    return HTML::ListScraper::Sequence->new(len => $len,
        instances => \@instances);
}

sub _is_tag {
    my ($self, $tag) = @_;

    return $tag =~ m/^[a-z0-9-:]+$/i;
}

sub on_start {
    my ($self, $rtag, $attr) = @_;

    my $tag = $rtag;
    $tag =~ s/\s*\/$//;

    if (!$self->_is_tag($tag)) {
        $self->{book}->append_text($tag);
	return;
    }

    if (exists($attr->{href}) && $attr->{href}) {
	$self->{book}->push_link($tag, $attr->{href});
    } else {
	$self->{book}->push_item($tag);
    }

    if ($tag ne $rtag) { # empty tag - close it
        $self->on_end($tag);
    }
}

sub on_text {
    my ($self, $text) = @_;

    $self->{book}->append_text($text);
}

sub on_end {
    my ($self, $tag) = @_;

    if (!$self->_is_tag($tag)) {
        $self->{book}->append_text($tag);
	return;
    }

    $self->{book}->push_item("/$tag");
}

1;

__END__