File Coverage

blib/lib/HTTP/AnyUA.pm

Criterion	Covered	Total	%
statement	125	165	75.7
branch	42	90	46.6
condition	27	82	32.9
subroutine	27	32	84.3
pod	14	14	100.0
total	235	383	61.3

package HTTP::AnyUA;
# ABSTRACT: An HTTP user agent programming interface unification layer


use 5.010;
use warnings;
use strict;

our $VERSION = '0.904'; # VERSION

use HTTP::AnyUA::Util;
use Module::Loader;
use Scalar::Util;


our $BACKEND_NAMESPACE;
our $MIDDLEWARE_NAMESPACE;
our @BACKENDS;
our %REGISTERED_BACKENDS;

BEGIN {
    $BACKEND_NAMESPACE      = __PACKAGE__ . '::Backend';
    $MIDDLEWARE_NAMESPACE   = __PACKAGE__ . '::Middleware';
}


sub _debug_log { print STDERR join(' ', @_), "\n" if $ENV{PERL_HTTP_ANYUA_DEBUG} }

sub _croak { require Carp; Carp::croak(@_) }
sub _usage { _croak("Usage: @_\n") }



sub new {
    my $class = shift;
    unshift @_, 'ua' if @_ % 2;
    my %args = @_;
    $args{ua} or _usage(q{HTTP::AnyUA->new(ua => $user_agent, %attr)});

    my $self;
    my @attr = qw(ua backend response_is_future);

    for my $attr (@attr) {
        $self->{$attr} = $args{$attr} if defined $args{$attr};
    }

    bless $self, $class;

    $self->_debug_log('Created with user agent', $self->ua);

    # call accessors to get the checks to run
    $self->ua;
    $self->response_is_future($args{response_is_future}) if defined $args{response_is_future};

    return $self;
}


sub ua { shift->{ua} or _croak 'User agent is required' }


sub response_is_future {
    my $self = shift;
    my $val  = shift;

    if (defined $val) {
        $self->_debug_log('Set response_is_future to', $val ? 'ON' : 'OFF');

        $self->_check_response_is_future($val);
        $self->{response_is_future} = $val;

        $self->_module_loader->load('Future') if $self->{response_is_future};
    }
    elsif (!defined $self->{response_is_future} && $self->{backend}) {
        $self->{response_is_future} = $self->backend->response_is_future;

        $self->_module_loader->load('Future') if $self->{response_is_future};
    }

    return $self->{response_is_future} || '';
}


sub backend {
    my $self = shift;

    return $self->{backend} if defined $self->{backend};

    $self->{backend} = $self->_build_backend;
    $self->_check_response_is_future($self->response_is_future);

    return $self->{backend};
}


sub request {
    my ($self, $method, $url, $args) = @_;
    $args ||= {};
    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or _usage(q{$any_ua->request($method, $url, \%options)});

    my $resp = eval { $self->backend->request(uc($method) => $url, $args) };
    if (my $err = $@) {
        return $self->_wrap_internal_exception($err);
    }

    return $self->_wrap_response($resp);
}


# adapted from HTTP/Tiny.pm
for my $sub_name (qw{get head put post delete}) {
    my %swap = (SUBNAME => $sub_name, METHOD => uc($sub_name));
    my $code = q[
sub {{SUBNAME}} {
    my ($self, $url, $args) = @_;
    @_ == 2 || (@_ == 3 && ref $args eq 'HASH')
        or _usage(q{$any_ua->{{SUBNAME}}($url, \%options)});
    return $self->request('{{METHOD}}', $url, $args);
}
    ];
    $code =~ s/\{\{([A-Z_]+)\}\}/$swap{$1}/ge;
    eval $code;     ## no critic
}


# adapted from HTTP/Tiny.pm
sub post_form {
    my ($self, $url, $data, $args) = @_;
    (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
        or _usage(q{$any_ua->post_form($url, $formdata, \%options)});

    my $headers = HTTP::AnyUA::Util::normalize_headers($args->{headers});
    delete $args->{headers};

    return $self->request(POST => $url, {
        %$args,
        content => HTTP::AnyUA::Util::www_form_urlencode($data),
        headers => {
            %$headers,
            'content-type' => 'application/x-www-form-urlencoded',
        },
    });
}


# adapted from HTTP/Tiny.pm
sub mirror {
    my ($self, $url, $file, $args) = @_;
    @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
        or _usage(q{$any_ua->mirror($url, $filepath, \%options)});

    $args->{headers} = HTTP::AnyUA::Util::normalize_headers($args->{headers});

    if (-e $file and my $mtime = (stat($file))[9]) {
        $args->{headers}{'if-modified-since'} ||= HTTP::AnyUA::Util::http_date($mtime);
    }
    my $tempfile = $file . int(rand(2**31));

    # set up the response body to be written to the file
    require Fcntl;
    sysopen(my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY())
        or return $self->_wrap_internal_exception(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);
    binmode $fh;
    $args->{data_callback} = sub { print $fh $_[0] };

    my $resp = $self->request(GET => $url, $args);

    my $finish = sub {
        my $resp = shift;

        close $fh
            or return HTTP::AnyUA::Util::internal_exception(qq/Error: Caught error closing temporary file $tempfile: $!\n/);

        if ($resp->{success}) {
            rename($tempfile, $file)
                or return HTTP::AnyUA::Util::internal_exception(qq/Error replacing $file with $tempfile: $!\n/);
            my $lm = $resp->{headers}{'last-modified'};
            if ($lm and my $mtime = HTTP::AnyUA::Util::parse_http_date($lm)) {
                utime($mtime, $mtime, $file);
            }
        }
        unlink($tempfile);

        $resp->{success} ||= $resp->{status} eq '304';

        return $resp;
    };

    if ($self->response_is_future) {
        return $resp->followed_by(sub {
            my $future = shift;
            my @resp = $future->is_done ? $future->get : $future->failure;
            my $resp = $finish->(@resp);
            if ($resp->{success}) {
                return Future->done(@resp);
            }
            else {
                return Future->fail(@resp);
            }
        });
    }
    else {
        return $finish->($resp);
    }
}


sub apply_middleware {
    my $self    = shift;
    my $class   = shift;

    if (!ref $class) {
        $class = "${MIDDLEWARE_NAMESPACE}::${class}" unless $class =~ s/^\+//;
        $self->_module_loader->load($class);
    }

    $self->{backend} = $class->wrap($self->backend, @_);
    $self->_check_response_is_future($self->response_is_future);

    return $self;
}


sub register_backend {
    my ($class, $ua_type, $backend_class) = @_;
    @_ == 3 or _usage(q{HTTP::AnyUA->register_backend($ua_type, $backend_package)});

    if ($backend_class) {
        $backend_class = "${BACKEND_NAMESPACE}::${backend_class}" unless $backend_class =~ s/^\+//;
        $REGISTERED_BACKENDS{$ua_type} = $backend_class;
    }
    else {
        delete $REGISTERED_BACKENDS{$ua_type};
    }
}


# turn a response into a Future if it needs to be
sub _wrap_response {
    my $self = shift;
    my $resp = shift;

    if ($self->response_is_future && !$self->backend->response_is_future) {
        # wrap the response in a Future
        if ($resp->{success}) {
            $self->_debug_log('Wrapped successful response in a Future');
            $resp = Future->done($resp);
        }
        else {
            $self->_debug_log('Wrapped failed response in a Future');
            $resp = Future->fail($resp);
        }
    }

    return $resp;
}

sub _wrap_internal_exception { shift->_wrap_response(HTTP::AnyUA::Util::internal_exception(@_)) }

# get a module loader object
sub _module_loader { shift->{_module_loader} ||= Module::Loader->new }

# get a list of potential backends that may be able to handle the user agent
sub _build_backend {
    my $self = shift;
    my $ua   = shift || $self->ua or _croak 'User agent is required';

    my $ua_type = Scalar::Util::blessed($ua);

    my @classes;

    if ($ua_type) {
        push @classes, $REGISTERED_BACKENDS{$ua_type} if $REGISTERED_BACKENDS{$ua_type};

        push @classes, "${BACKEND_NAMESPACE}::${ua_type}";

        if (!@BACKENDS) {
            # search for some backends to try
            @BACKENDS = sort $self->_module_loader->find_modules($BACKEND_NAMESPACE);
            $self->_debug_log('Found backends to try (' . join(', ', @BACKENDS) . ')');
        }

        for my $backend_type (@BACKENDS) {
            my $plugin = $backend_type;
            $plugin =~ s/^\Q${BACKEND_NAMESPACE}\E:://;
            push @classes, $backend_type if $ua->isa($plugin);
        }
    }
    else {
        push @classes, $REGISTERED_BACKENDS{$ua} if $REGISTERED_BACKENDS{$ua};
        push @classes, "${BACKEND_NAMESPACE}::${ua}";
    }

    for my $class (@classes) {
        if (eval { $self->_module_loader->load($class); 1 }) {
            $self->_debug_log("Found usable backend (${class})");
            return $class->new($self->ua);
        }
        else {
            $self->_debug_log($@);
        }
    }

    _croak 'Cannot find a usable backend that supports the given user agent';
}

# make sure the response_is_future setting is compatible with the backend
sub _check_response_is_future {
    my $self = shift;
    my $val  = shift;

    # make sure the user agent is not non-blocking
    if (!$val && $self->{backend} && $self->backend->response_is_future) {
        _croak 'Cannot disable response_is_future with a non-blocking user agent';
    }
}

1;

__END__