File Coverage

blib/lib/HTML/RelExtor.pm

Criterion	Covered	Total	%
statement	15	72	20.8
branch	0	20	0.0
condition	0	13	0.0
subroutine	5	19	26.3
pod	3	3	100.0
total	23	127	18.1

package HTML::RelExtor;

use strict;
use vars qw($VERSION);
$VERSION = '0.03';

use HTML::Parser;
use URI;

use base qw(HTML::Parser);

sub new {
    my($class, %args) = @_;
    my $self = $class->SUPER::new(
	start_h     => [ "_start_tag", "self,tagname,attr" ],
	report_tags => [ qw(a link base) ],
    );
    if (my $base = delete $args{base}) {
	$self->{relextor_base} = $base;
    }
    $self;
}

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

    # If there's , change the base URL
    if ($tag eq 'base' && exists $attr->{href}) {
	$self->{relextor_base} = $attr->{href};
	return;
    }

    # no 'rel' nor 'rev' attribute
    return unless exists $attr->{rel} or exists $attr->{rev};

    my $href = $attr->{href} or return;
    $href = URI->new_abs($href, $self->{relextor_base})->as_string
	if $self->{relextor_base};
    my $link = HTML::RelExtor::Link->new($tag, $href, $attr);
    if ($tag eq 'a') {
	$self->handler(text => sub {
			   my($self, $text) = @_;
			   $link->{text} = $text;
			   $self->handler(text => undef);
		       }, "self,dtext");
    }
    push @{$self->{links}}, $link;
}

sub links {
    my $self = shift;
    my %args = @_;
    my @links = $self->{links} ? @{$self->{links}} : ();

    if ($args{rel} && $args{rev}) {
        Carp::croak("You can't pass both rev and rel to the links()");
    }

    if ($args{rel}) {
        @links = grep $_->has_rel($args{rel}), @links;
    } elsif ($args{rev}) {
        @links = grep $_->has_rev($args{rev}), @links;
    }

    return @links;
}

sub parse_file {
    my $self = shift;
    delete $self->{links};
    $self->SUPER::parse_file(@_);
}

package HTML::RelExtor::Link;

sub new {
    my($class, $tag, $href, $attr) = @_;
    my @rel = grep length, split /\s+/, ($attr->{rel} || '');
    my @rev = grep length, split /\s+/, ($attr->{rev} || '');
    bless {
	tag  => $tag,
	href => $href,
	attr => $attr,
	rel  => \@rel,
	rev  => \@rev,
    }, $class;
}

sub tag {
    my $self = shift;
    $self->{tag};
}

sub href {
    my $self = shift;
    $self->{href};
}

sub attr {
    my $self = shift;
    $self->{attr};
}

sub rel {
    my $self = shift;
    @{$self->{rel}};
}

sub rev {
    my $self = shift;
    @{$self->{rev}};
}

sub has_rel {
    my($self, $tag) = @_;
    scalar grep { $_ eq $tag } $self->rel;
}

sub has_rev {
    my($self, $tag) = @_;
    scalar grep { $_ eq $tag } $self->rev;
}

sub text {
    my $self = shift;
    $self->{text};
}

1;
__END__