File Coverage

blib/lib/Alien/Build/Plugin/Fetch/HTTPTiny.pm

Criterion	Covered	Total	%
statement	32	78	41.0
branch	3	26	11.5
condition	4	26	15.3
subroutine	8	9	88.8
pod	1	1	100.0
total	48	140	34.2

package Alien::Build::Plugin::Fetch::HTTPTiny;

use strict;
use warnings;
use 5.008004;
use Alien::Build::Plugin;
use File::Basename ();
use Alien::Build::Util qw( _ssl_reqs );
use Carp ();

# ABSTRACT: Plugin for fetching files using HTTP::Tiny
our $VERSION = '2.46'; # VERSION


has '+url' => '';


has ssl => 0;

# ignored for compatability
has bootstrap_ssl => 1;

sub init
{
  my($self, $meta) = @_;

  $meta->add_requires('share' => 'HTTP::Tiny' => '0.044' );
  $meta->add_requires('share' => 'URI' => 0 );

  $meta->prop->{start_url} ||= $self->url;
  $self->url($meta->prop->{start_url});
  $self->url || Carp::croak('url is a required property');

  if($self->url =~ /^https:/ || $self->ssl)
  {
    my $reqs = _ssl_reqs;
    foreach my $mod (sort keys %$reqs)
    {
      $meta->add_requires('share' => $mod => $reqs->{$mod});
    }
  }

  $meta->register_hook( fetch => sub {
    my($build, $url, %options) = @_;
    $url ||= $self->url;

    my %headers;
    if(my $headers = $options{http_headers})
    {
      if(ref $headers eq 'ARRAY')
      {
        my @headers = @$headers;
        while(@headers)
        {
          my $key = shift @headers;
          my $value = shift @headers;
          unless(defined $key && defined $value)
          {
            $build->log("Fetch for $url with http_headers contains undef key or value");
            next;
          }
          push @{ $headers{$key} }, $value;
        }
      }
      else
      {
        $build->log("Fetch for $url with http_headers that is not an array reference");
      }
    }

    my $ua = HTTP::Tiny->new( agent => "Alien-Build/@{[ $Alien::Build::VERSION || 'dev' ]} " );
    my $res = $ua->get($url, { headers => \%headers });

    unless($res->{success})
    {
      my $status = $res->{status} || '---';
      my $reason = $res->{reason} || 'unknown';

      $build->log("$status $reason fetching $url");
      if($status == 599)
      {
        $build->log("exception: $_") for split /\n/, $res->{content};

        my($can_ssl, $why_ssl) = HTTP::Tiny->can_ssl;
        if(! $can_ssl)
        {
          if($res->{redirects}) {
            foreach my $redirect (@{ $res->{redirects} })
            {
              if(defined $redirect->{headers}->{location} && $redirect->{headers}->{location} =~ /^https:/)
              {
                $build->log("An attempt at a SSL URL https was made, but your HTTP::Tiny does not appear to be able to use https.");
                $build->log("Please see: https://metacpan.org/pod/Alien::Build::Manual::FAQ#599-Internal-Exception-errors-downloading-packages-from-the-internet");
              }
            }
          }
        }
      }

      die "error fetching $url: $status $reason";
    }

    my($type) = split /;/, $res->{headers}->{'content-type'};
    $type = lc $type;
    my $base            = URI->new($res->{url});
    my $filename        = File::Basename::basename do { my $name = $base->path; $name =~ s{/$}{}; $name };

    # TODO: this doesn't get exercised by t/bin/httpd
    if(my $disposition = $res->{headers}->{"content-disposition"})
    {
      # Note: from memory without quotes does not match the spec,
      # but many servers actually return this sort of value.
      if($disposition =~ /filename="([^"]+)"/ || $disposition =~ /filename=([^\s]+)/)
      {
        $filename = $1;
      }
    }

    if($type eq 'text/html')
    {
      return {
        type    => 'html',
        base    => $base->as_string,
        content => $res->{content},
      };
    }
    else
    {
      return {
        type     => 'file',
        filename => $filename || 'downloadedfile',
        content  => $res->{content},
      };
    }

  });

  $self;
}

1;

__END__