File Coverage

blib/lib/HTML/FormatText/WithLinks.pm

Criterion	Covered	Total	%
statement	153	156	98.0
branch	54	60	90.0
condition	33	38	86.8
subroutine	24	24	100.0
pod	4	16	25.0
total	268	294	91.1

package HTML::FormatText::WithLinks;

use strict;
use URI::WithBase;
use HTML::TreeBuilder;
use base qw(HTML::FormatText);
use vars qw($VERSION);

$VERSION = '0.15';

sub new {

    my $proto = shift;
    my $class = ref( $proto ) || $proto;
    my $self  = $class->SUPER::new( @_ );
    $self->configure() unless @_;

    bless ( $self, $class );
    return $self;

}

sub configure {

    my ($self, $hash) = @_;

    # a base uri so we can resolve relative uris
    $self->{base} = $hash->{base};
    delete $hash->{base};
    $self->{base} =~ s#(.*?)/[^/]*$#$1/# if $self->{base};

    $self->{doc_overrides_base} = $hash->{doc_overrides_base};
    delete $hash->{doc_overrides_base};

    $self->{before_link} = '[%n]';
    $self->{after_link} = '';
    $self->{footnote} = '%n. %l';
    $self->{link_num_generator} = sub { return shift() + 1 };

    $self->{unique_links} = 0;

    $self->{anchor_links} = 1;

    $self->{skip_linked_urls} = 0;

    $self->{_link_track} = {};

    $self->{bold_marker}    = '_';
    $self->{italic_marker}  = '/';

    foreach ( qw( before_link after_link footnote link_num_generator
                  with_emphasis bold_marker italic_marker
                  unique_links anchor_links skip_linked_urls ) ) {
        $self->{ $_ } = $hash->{ $_ } if exists $hash->{ $_ };
        delete $hash->{ $_ };
    }

    $self->SUPER::configure($hash);

}

# we need to do this as if you pass an HTML fragment without any
# containing block level markup (e.g. a p tag) then no indentation
# takes place so if we've not got a cur_pos we indent.
sub textflow {
    my $self = shift;
    $self->goto_lm unless defined $self->{cur_pos};
    $self->SUPER::textflow(@_);
}

sub head_start {
    my ($self) = @_;
    $self->SUPER::head_start();

    # we don't care about what the documents says it's base is
    if ( $self->{base} and not $self->{doc_overrides_base} ) {
        return 0;
    }

    # descend into  for possible  there, even if superclass not
    # interested (as of HTML::FormatText 2.04 it's not)
    return 1;
}

#  is supposed to be inside , but no need to demand that.
# "lynx -source" sticks a  at the very start of the document, before
# even , so accepting  anywhere lets that work.
sub base_start {
    my ($self, $node) = @_;
    if (my $href = $node->attr('href')) {
        $self->{base} = $href;
    }

    # allow for no superclass base_start() in HTML::FormatText 2.04
    if (! HTML::FormatText->can('base_start')) {
        return 0;
    }

    # chain up if it exists in the future
    return $self->SUPER::base_start();
}

sub a_start {

    my $self = shift;
    my $node = shift;
    # local urls are no use so we have to make them absolute
    my $href = $node->attr('href') || '';
    if ($href && $self->{anchor_links} == 0 && $href =~ m/^#/o) {
        $href = '';
    }
    elsif ($href and $self->{skip_linked_urls} and $href eq $node->as_text) {
        $href = '';
    }
    if ( $href ) {
        if ($href !~ m#^https?:|^mailto:#o) {
            $href = URI::WithBase->new($href, $self->{base})->abs();
        }
        if ($self->{unique_links})
        {
            if (defined $self->{_link_track}->{$href})
            {
                $self->out( $self->text('before_link', $self->{_link_track}->{$href}, $href ) );
            } else {
                push @{$self->{_links}}, $href;
                $self->{_link_track}->{$href} = $#{$self->{_links}};
                $self->out( $self->text('before_link', $#{$self->{_links}}, $href ) );
            }
        } else {
            push @{$self->{_links}}, $href;
            $self->out( $self->text('before_link') );
        }
    }
    $self->SUPER::a_start();

}

sub a_end {

    my $self = shift;
    my $node = shift;
    my $text;
    unless ($self->{skip_linked_urls} and $node->attr('href') eq $node->as_text) {
        if ($self->{unique_links})
        {
            my $href = $node->attr('href');
            $text = $self->text('after_link', $self->{_link_track}->{$href}, $href);
        } else {
            $text = $self->text('after_link');
        }
# If we're just dealing with a fragment of HTML, with a link at the
# end, we get a space before the first footnote link if we do
# $self->out( '' )
        if ($text ne '') {
            $self->out( $text );
        }
    }
    $self->SUPER::a_end();

}

sub b_start {
    my $self = shift;
    $self->out( $self->{'bold_marker'} ) if $self->{ with_emphasis };
    $self->SUPER::b_start();
}

sub b_end {
    my $self = shift;
    $self->out( $self->{'bold_marker'} ) if $self->{ with_emphasis };
    $self->SUPER::b_end();
}

sub i_start {
    my $self = shift;
    $self->out( $self->{'italic_marker'} ) if $self->{ with_emphasis };
    $self->SUPER::i_start();
}

sub i_end {
    my $self = shift;
    $self->out( $self->{'italic_marker'} ) if $self->{ with_emphasis };
    $self->SUPER::i_end();
}

# print out our links
sub html_end {

    my $self = shift;
    if ( $self->{_links} and @{$self->{_links}} and $self->{footnote} ) {
        $self->nl; $self->nl; # be tidy
        $self->goto_lm;
        for (0 .. $#{$self->{_links}}) {
            $self->goto_lm;
            $self->out(
                $self->text( 'footnote', $_, $self->{_links}->[$_] )
            );
            $self->nl;
        }
    }
    $self->SUPER::end();

}

sub _link_num {

    my ($self, $num) = @_;
    $num = $#{$self->{_links}} unless defined $num;
    return &{$self->{link_num_generator}}($num);

}

sub text {

    my ($self, $type, $num, $href) = @_;

    if ($self->{_links} and @{$self->{_links}}) {
        $href = $self->{_links}->[$#{$self->{_links}}]
                unless (defined $num and defined $href);
    }
    $num = $self->_link_num($num);
    my $text = $self->{$type};
    $text =~ s/%n/$num/g;
    $text =~ s/%l/$href/g;
    return $text;
}

sub parse {

    my $self = shift;
    my $text = shift;

    return undef unless defined $text;
    return '' if $text eq '';

    my $tree = HTML::TreeBuilder->new->parse( $text );

    return $self->_parse( $tree );
}

sub parse_file {

    my $self = shift;
    my $file = shift;

    unless (-e $file and -f $file) {
        $self->error("$file not found or not a regular file");
        return undef;
    }

    my $tree = HTML::TreeBuilder->new->parse_file( $file );

    return $self->_parse( $tree );
}

sub _parse {

    my $self = shift;
    my $tree = shift;

    $self->{_link_track} = {};
    $self->{_links} = [];

    unless ( $tree ) {
        $self->error( "HTML::TreeBuilder problem" . ( $! ? ": $!" : '' ) );
        return undef;
    }
    $tree->eof();

    my $return_text = $self->format( $tree );

    $tree->delete;

    return $return_text;
}


sub error {
    my $self = shift;
    if (@_) {
        $self->{error} = shift;
    }
    return $self->{error};
}

1;

__END__