File Coverage

blib/lib/Wallflower/Util.pm

Criterion	Covered	Total	%
statement	34	34	100.0
branch	2	2	100.0
condition	3	3	100.0
subroutine	9	9	100.0
pod	1	1	100.0
total	49	49	100.0

package Wallflower::Util;
$Wallflower::Util::VERSION = '1.014';
use strict;
use warnings;

use Exporter;
use HTTP::Headers;
use HTML::LinkExtor;

our @ISA = qw( Exporter );
our @EXPORT_OK = qw( links_from );

# some code to obtain links to resources
my %linkextor = (
    'text/html'                     => \&_links_from_html,
    'text/x-server-parsed-html'     => \&_links_from_html,
    'application/xhtml+xml'         => \&_links_from_html,
    'application/vnd.wap.xhtml+xml' => \&_links_from_html,
    'text/css'                      => \&_links_from_css,
);

sub links_from {
    my ( $response, $url ) = @_;
    my $le = $linkextor{ HTTP::Headers->new( @{ $response->[1] } )
            ->content_type };
    return if !$le;
    return grep !$_->scheme || $_->scheme =~ /^http/,
      $le->( $response->[2], $url );
}

# HTML
sub _links_from_html {
    my ( $file, $url ) = @_;
    my @links;
    my $parser = HTML::LinkExtor->new(
        sub {
            my ( $tag, @pairs ) = @_;
            my $i = 0;
            push @links, grep $i++ % 2, @pairs;
        },
        $url
    );
    $parser->parse_file("$file");
    return @links;
}

# CSS
my $css_regexp = qr{
    (?:
      \@import\s+(?:"([^"]+)"|'([^']+)')
    | url\((?:"([^"]+)"|'([^']+)'|([^)]+))\)
    )
}x;
sub _links_from_css {
    my ( $file, $url ) = @_;

    my $content = do { local ( *ARGV, $/ ); @ARGV = ("$file"); <> };
    return map URI->new_abs( $_, $url ), grep defined,
        $content =~ /$css_regexp/gc;
}

1;

__END__