File Coverage

blib/lib/Github/ReleaseFetcher.pm

Criterion	Covered	Total	%
statement	52	56	92.8
branch	13	24	54.1
condition	5	13	38.4
subroutine	9	9	100.0
pod	1	1	100.0
total	80	103	77.6

package Github::ReleaseFetcher 1.001;

use strict;
use warnings;

# ABSTRACT: Fetch either the latest or a particular named version of a file in a release from github
use 5.006;
use v5.14.0;    # Before 5.006, v5.10.0 would not be understood.

use Carp::Always;
use HTTP::Tiny();
use HTML::TreeBuilder::Select();
use File::Basename qw{basename};


our $BASE_URI = "http://github.com";

sub fetch {
    my ( $outdir, $owner, $project, $search, $rename, $version, $ua ) = @_;

    die "Must pass outdir that exists" if $outdir && !-d $outdir;
    die "Must pass owner"   unless $owner;
    die "Must pass project" unless $owner;

    $outdir //= "";

    $version //= 'latest';
    my $index = "$BASE_URI/$owner/$project/releases/$version";

    $ua //= HTTP::Tiny->new();
    my $res;

    # Figure out *what* the latest version number is.
    if ( $version eq 'latest' ) {
        my $res = $ua->get($index);
        die "$res->{reason} :\n$res->{content}\n" unless $res->{success};

        #Snag the url we were redirected to, as this is the actual version
        $version = basename( $res->{url} );
    }
    $index = "$BASE_URI/$owner/$project/releases/expanded_assets/$version";
    $res   = $ua->get($index);
    die "$res->{reason} :\n$res->{content}\n" unless $res->{success};

    my $parsed = HTML::TreeBuilder::Select->new_from_content( $res->{content} );
    my @matches =
      map  { $_->[0][0] }
      grep { ref $_ eq "ARRAY" && ref $_->[0] eq "ARRAY"; }
      map  { $_->extract_links() } $parsed->select('a');
    @matches = grep { $_ =~ $search } @matches if $search;

    my %names = map {
        my $subj = $_;
        my $name = $rename // basename($subj);
        "$BASE_URI/$subj" => "$outdir/$name"
    } @matches;

    foreach my $to_write ( reverse sort keys %names ) {
        $ua->mirror( $to_write, $names{$to_write} ) if $outdir;
        last                                        if $rename;
    }

    return keys(%names) unless $outdir;

    my @written = values(%names);
    return pop(@written) if $rename;
    return @written;
}

1;

__END__