File Coverage

blib/lib/HTML/ListScraper/Interactive.pm

Criterion	Covered	Total	%
statement	71	85	83.5
branch	18	32	56.2
condition	14	22	63.6
subroutine	9	9	100.0
pod	2	4	50.0
total	114	152	75.0

package HTML::ListScraper::Interactive;

use warnings;
use strict;

use HTML::Entities;

require Exporter;

use vars qw(@ISA @EXPORT_OK);

@ISA = qw(Exporter);
@EXPORT_OK = qw(format_tags canonicalize_tags);

use Class::Generate qw(class);

class 'HTML::ListScraper::FormTag' => {
    name => { type => '$', required => 1 },
    index => { type => '$', required => 1, readonly => 1 },
    link => { type => '$', required => 1, readonly => 1 },
    text => { type => '$', required => 1, readonly => 1 },
    '&close_name' => q{ $name .= '/'; }
};

sub is_opening {
    my $tag = shift;

    return $tag !~ m~\/~;
}

sub is_closing {
    my $tag = shift;

    return $tag =~ m~^\/~;
}

sub format_tags {
    my ($scraper, $tags, $incl) = @_;

    my $incl_attr;
    my $incl_text;
    my $incl_index;
    if (ref($incl)) {
        $incl_attr = $incl->{attr};
        $incl_text = $incl->{text};
        $incl_index = $incl->{index};
    }

    my @buffer;
    my @stack;
    foreach my $td (@$tags) {
        my $name = $td->name;
	my $tag = $name;
	$tag =~ s~^\/~~;

	my $text = $td->text || '';
	$text =~ s/[\s[:cntrl:]]+/ /g;

	my $link = $td->link || '';
	$link =~ s/[\s[:cntrl:]]+//g;

	if ($name eq $tag) {
	    push @stack, [ $tag, scalar(@buffer) ];
	    push @buffer, HTML::ListScraper::FormTag->new(name => $name,
                index => $td->index, link => $link, text => $text);
	} else {
	    while (scalar(@stack) &&
		    ($stack[scalar(@stack) - 1]->[0] ne $tag)) {
		if ($scraper->is_unclosed_tag(
                        $stack[scalar(@stack) - 1]->[0])) {
		    my $pair = pop @stack;

		    $buffer[$pair->[1]]->close_name();
		} else {
		    last;
		}
	    }

	    if (scalar(@stack)) {
	        pop @stack;
	    }

	    push @buffer, HTML::ListScraper::FormTag->new(name => $name,
                index => $td->index, link => $link, text => $text);
	}
    }

    while (scalar(@stack)) {
        my $pair = pop @stack;
	$buffer[$pair->[1]]->close_name();
    }

    my @out;
    my $prev;
    my $prev_index;
    my $depth = 0;
    foreach my $ft (@buffer) {
        my $name = $ft->name;
        if (defined($prev)) {
	    my $op = is_opening($prev);
	    my $cl = is_closing($name);
  	    if ($op && !$cl) {
	        ++$depth;
	    } elsif (!$op && $cl) {
	        if ($depth > 0) {
		    --$depth;
		}
	    }
        }

	my $indent = ' ' x (2 * $depth);

	my $attr = '';
	if ($incl_attr && $ft->link) {
	    $attr = ' href="' . encode_entities($ft->link, '"') . '"';
	}

	my $lncol = '';
	if ($incl_index) {
	    $lncol = $ft->index . "\t";
	}

	if (defined($prev_index) && (($ft->index - $prev_index) != 1)) {
	    push @out, "\n";
	}

	push @out, "$lncol$indent<$name$attr>\n";

	if ($incl_text && ($ft->text !~ /^[\s\r\n]*$/)) {
	    $lncol = $incl_index ? "\t" : "";
	    push @out, $lncol . $indent . encode_entities($ft->text, "<>&") . "\n";
	}

	$prev = $name;
	$prev_index = $ft->index;
    }

    return wantarray ? @out : \@out;
}

sub canonicalize_tags {
    my @out;
    foreach (@_) {
        my $ln = lc $_;
	$ln =~ s/^\s*
	$ln =~ s/\/?>[\s\r\n]*$//;

	if ($ln) {
	    push @out, $ln;
	}
    }

    return wantarray ? @out : \@out;
}

1;

__END__