File Coverage

blib/lib/WWW/PGXN.pm

Criterion	Covered	Total	%
statement	167	170	98.2
branch	48	56	85.7
condition	14	19	73.6
subroutine	45	45	100.0
pod	14	14	100.0
total	288	304	94.7

package WWW::PGXN;

use 5.010;
use strict;
use WWW::PGXN::Distribution;
use WWW::PGXN::Extension;
use WWW::PGXN::User;
use WWW::PGXN::Tag;
use WWW::PGXN::Mirror;
use HTTP::Tiny;
use URI::Template;
use JSON ();
use Carp;

our $VERSION = v0.13.0;

sub new {
    my($class, %params) = @_;
    my $self = bless {} => $class;
    for my $key (qw(url proxy)) {
        $self->$key($params{$key}) if exists $params{$key}
    }
    return $self;
}

sub get_distribution {
    my ($self, $dist, $version) = @_;
    my $data = $self->_fetch_json(
        (defined $version ? 'meta' : 'dist'),
        { dist => lc $dist, version => lc($version || '') }
    ) or return;
    WWW::PGXN::Distribution->new($self, $data);
}

sub get_extension {
    my ($self, $ext) = @_;
    my $data = $self->_fetch_json(extension => { extension => lc $ext })
        or return;
    WWW::PGXN::Extension->new($self, $data);
}

sub get_user {
    my ($self, $user) = @_;
    my $data = $self->_fetch_json(user => { user => lc $user }) or return;
    WWW::PGXN::User->new($data);
}

sub get_tag {
    my ($self, $tag) = @_;
    my $data = $self->_fetch_json(tag => { tag => lc $tag }) or return;
    WWW::PGXN::Tag->new($data);
}

sub get_stats {
    my ($self, $name) = @_;
    my $data = $self->_fetch_json(stats => { stats => lc $name }) or return;
}

sub get_userlist {
    my ($self, $letter) = @_;
    return undef unless $self->_uri_templates->{userlist};
    return $self->_fetch_json(userlist => { letter => lc $letter }) || [];
}

my %valid_in = ( map { $_ => undef } qw(docs dists extensions users tags));

sub search {
    my ($self, %params) = @_;
    my $url = $self->url;
    my $in  = delete $params{in}
        or croak 'Missing required "in" parameter to search()';

    croak qq{Invalid "in" parameter to search(); Must be one of:\n}
        . join("\n", map { "* $_" } sort keys %valid_in)
        unless exists $valid_in{$in};

    if ($url->scheme eq 'file') {
        # Fetch it via PGXN::API::Searcher.
        my $searcher = $self->{_searcher} ||= PGXN::API::Searcher->new(
            File::Spec->catdir($url->path_segments)
        );
        return $searcher->search(in => $in, %params);
    }

    my $qurl = $self->_url_for(search => { in => $in });
    $qurl->query_form({
        map { substr($_, 0, 1) => $params{$_} } keys %params
    });
    my $res = $self->_fetch($qurl) or return;
    return JSON->new->utf8->decode($res->{content});
}

sub mirrors {
    my $self = shift;
    return @{ $self->{mirrors} ||= do {
        my $mirrors = $self->_fetch_json('mirrors');
        [ map { WWW::PGXN::Mirror->new($_) } @{ $mirrors } ];
    } };
}

sub spec {
    my ($self, $format) = @_;
    $format ||= 'txt';
    my $res = $self->_fetch(
        $self->_url_for('spec' => { format => $format })
    ) or return;
    utf8::decode $res->{content};
    return $res->{content};
}

sub url {
    my $self = shift;
    return $self->{url} unless @_;
    (my $url = shift) =~ s{/+$}{}g;
    $self->{url} = URI->new($url);
    require PGXN::API::Searcher if $self->{url}->scheme eq 'file';
    delete $self->{_req};
    delete $self->{_searcher};
    $self->{url};
}

sub proxy {
    my $self = shift;
    return $self->{proxy} unless @_;
    $self->{proxy} = shift;
}

BEGIN {
    for my $thing (qw(meta download source)) {
        no strict 'refs';
        *{"$thing\_url_for"} = sub {
            $_[0]->_url_for( $thing => { dist => lc $_[1], version => lc $_[2] });
        };
        *{"$thing\_path_for"} = sub {
            $_[0]->_path_for( $thing => { dist => lc $_[1], version => lc $_[2] });
        };
    }

    for my $thing (qw(tag extension user)) {
        no strict 'refs';
        *{"$thing\_url_for"} = sub {
            $_[0]->_url_for( $thing => { $thing => lc $_[1] });
        };
        *{"$thing\_path_for"} = sub {
            $_[0]->_path_for( $thing => { $thing => lc $_[1] });
        };
    }
}

sub html_doc_path_for {
    my ($self, $dist, $version, $path) = @_;
    $self->_path_for(htmldoc => {
        dist    => lc $dist,
        version => lc $version,
        docpath => $path,
    });
}

sub html_doc_url_for {
    my $self = shift;
    return URI->new($self->url . $self->html_doc_path_for(@_));
}

sub _uri_templates {
    my $self = shift;
    return $self->{uri_templates} ||= { do {
        my $req = $self->_request;
        my $url = URI->new($self->url . '/index.json');
        my $res = $req->get($url);
        croak "Request for $url failed: $res->{status}: $res->{reason}\n"
            unless $res->{success};
        my $tmpl = JSON->new->utf8->decode($res->{content});
        map { $_ => URI::Template->new($tmpl->{$_}) } keys %{ $tmpl };
    }};
}

sub _path_for {
    my ($self, $name, $vars) = @_;
    my $tmpl = $self->_uri_templates->{$name}
        or croak qq{No URI template named "$name"};
    return $tmpl->process($vars);
}

sub _url_for {
    my $self = shift;
    return URI->new($self->url . $self->_path_for(@_));
}

sub _request {
    my $self = shift;
    $self->{_req} ||= $self->url =~ m{^file:} ? WWW::PGXN::FileReq->new : HTTP::Tiny->new(
        agent => __PACKAGE__ . '/' . __PACKAGE__->VERSION,
        proxy => $self->proxy,
    );
}

sub _fetch {
    my ($self, $url) = @_;
    my $res = $self->_request->get($url);
    return $res if $res->{success};
    return if $res->{status} == 404;
    croak "Request for $url failed: $res->{status}: $res->{reason}\n";
}

sub _fetch_json {
    my $self = shift;
    my $res = $self->_fetch($self->_url_for(@_)) or return;
    return JSON->new->utf8->decode($res->{content});
}

sub _download_to {
    my ($self, $file) = (shift, shift);
    my $url = $self->_url_for(download => @_);
    my $res = $self->_fetch($url);
    if (-e $file) {
        if (-d $file) {
            my @seg = $url->path_segments;
            $file = File::Spec->catfile($file, $seg[-1]);
        } else {
            croak "$file already exists";
        }
    }

    open my $fh, '>:raw', $file or die "Cannot open $file: $!\n";
    print $fh $res->{content};
    close $fh or die "Cannot close $file: $!\n";
    return $file;
}

package
WWW::PGXN::FileReq;

use strict;
use URI::file ();
use File::Spec ();
use URI::Escape ();

sub new {
    bless {} => shift;
}

sub get {
    my $self = shift;
    my $file = File::Spec->catfile(shift->path_segments);

    return {
        success => 0,
        status  => 404,
        reason  => 'not found',
        headers => {},
    } unless -e $file;

    open my $fh, '<:raw', $file or return {
        success => 0,
        status  => 500,
        reason  => $!,
        headers => {},
    };

    local $/;
    return {
        success => 1,
        status  => 200,
        reason  => 'OK',
        content => <$fh> || undef,
        headers => {},
    };
}

1;
__END__