File Coverage

blib/lib/Alien/Build/Plugin/Decode/Mojo.pm
Criterion Covered Total %
statement 25 42 59.5
branch 4 14 28.5
condition n/a
subroutine 7 8 87.5
pod 1 1 100.0
total 37 65 56.9


line stmt bran cond sub pod time code
1             package Alien::Build::Plugin::Decode::Mojo;
2              
3 2     2   225248 use strict;
  2         10  
  2         60  
4 2     2   25 use warnings;
  2         4  
  2         47  
5 2     2   42 use 5.008001;
  2         7  
6 2     2   904 use Alien::Build::Plugin;
  2         5220  
  2         14  
7 2     2   188 use Module::Load ();
  2         5  
  2         1091  
8              
9             # ABSTRACT: Plugin to extract links from HTML using Mojo::DOM or Mojo::DOM58
10             our $VERSION = '0.02'; # VERSION
11              
12              
13             sub _load ($)
14             {
15 2     2   6 eval { Module::Load::load($_[0]) };
  2         9  
16 2 50       629 $@ eq '' ? 1 : 0;
17             }
18              
19             has _class => sub {
20             return 'Mojo::DOM58' if _load 'Mojo::DOM58';
21             return 'Mojo::DOM' if _load 'Mojo::DOM' && _load 'Mojolicious' && eval { Mojolicious->VERSION('7.00') };
22             return 'Mojo::DOM58';
23             };
24              
25             sub init
26             {
27 3     3 1 23545 my($self, $meta) = @_;
28              
29 3         15 $meta->add_requires('share' => 'URI' => 0);
30 3         51 $meta->add_requires('share' => 'URI::Escape' => 0);
31              
32 3 100       44 if($self->_class eq 'Mojo::DOM58')
    50          
33             {
34 2         34 $meta->add_requires('share' => 'Mojo::DOM58' => '1.00');
35             }
36             elsif($self->_class eq 'Mojo::DOM')
37             {
38 1         18 $meta->add_requires('share' => 'Mojolicious' => '7.00');
39 1         14 $meta->add_requires('share' => 'Mojo::DOM' => '0');
40             }
41             else
42             {
43 0         0 die "bad class";
44             }
45              
46             $meta->register_hook( decode => sub {
47 0     0     my(undef, $res) = @_;
48              
49 0           die "do not know how to decode @{[ $res->{type} ]}"
50 0 0         unless $res->{type} eq 'html';
51              
52 0           my $dom = $self->_class->new($res->{content});
53              
54 0           my $base = URI->new($res->{base});
55              
56 0 0         if(my $base_element = $dom->find('head base')->first)
57             {
58 0           my $href = $base_element->attr('href');
59 0 0         $base = URI->new($href) if defined $href;
60             }
61              
62             my @list = map {
63 0           my $url = URI->new_abs($_, $base);
64 0           my $path = $url->path;
65 0           $path =~ s{/$}{}; # work around for Perl 5.8.7- gh#8
66             {
67 0           filename => URI::Escape::uri_unescape(File::Basename::basename($path)),
68             url => URI::Escape::uri_unescape($url->as_string),
69             }
70             }
71             grep !/^\.\.?\/?$/,
72 0 0         map { $_->attr('href') || () }
73 0           @{ $dom->find('a')->to_array };
  0            
74              
75             return {
76 0           type => 'list',
77             list => \@list,
78             };
79             })
80              
81              
82 3         56 }
83              
84             1;
85              
86             __END__