File Coverage

blib/lib/URI/Fetch.pm

Criterion	Covered	Total	%
statement	39	115	33.9
branch	0	42	0.0
condition	0	27	0.0
subroutine	14	15	93.3
pod	1	1	100.0
total	54	200	27.0

package URI::Fetch;
$URI::Fetch::VERSION = '0.15';
use 5.008001;
use strict;
use warnings;

use base qw( Class::ErrorHandler );

use LWP::UserAgent;
use Carp qw( croak );
use URI;
use URI::Fetch::Response;

our $HAS_ZLIB;
BEGIN {
    $HAS_ZLIB = eval "use Compress::Zlib (); 1;";
}

use constant URI_OK                => 200;
use constant URI_MOVED_PERMANENTLY => 301;
use constant URI_NOT_MODIFIED      => 304;
use constant URI_GONE              => 410;

sub fetch {
    my $class = shift;
    my($uri, %param) = @_;

    # get user parameters
    my $cache        = delete $param{Cache};
    my $ua           = delete $param{UserAgent};
    my $p_etag       = delete $param{ETag};
    my $p_lastmod    = delete $param{LastModified};
    my $content_hook = delete $param{ContentAlterHook};
    my $p_no_net     = delete $param{NoNetwork};
    my $p_cache_grep = delete $param{CacheEntryGrep};
    my $freeze       = delete $param{Freeze};
    my $thaw         = delete $param{Thaw};
    my $force        = delete $param{ForceResponse};
    croak("Unknown parameters: " . join(", ", keys %param))
        if %param;

    my $ref;
    if ($cache) {
        unless ($freeze && $thaw) {
            require Storable;
            $thaw = \&Storable::thaw;
            $freeze = \&Storable::freeze;
        }
        if (my $blob = $cache->get($uri)) {
            $ref = $thaw->($blob);
        }
    }

    # NoNetwork support (see pod docs below for logic clarification)
    if ($p_no_net) {
        croak("Invalid NoNetworkValue (negative)") if $p_no_net < 0;
        if ($ref && ($p_no_net == 1 || $ref->{CacheTime} > time() - $p_no_net)) {

            my $fetch = URI::Fetch::Response->new;
            $fetch->status(URI_OK);
            $fetch->content($ref->{Content});
            $fetch->etag($ref->{ETag});
            $fetch->last_modified($ref->{LastModified});
            $fetch->content_type($ref->{ContentType});
            return $fetch;
        }
        return undef if $p_no_net == 1;
    }

    $ua ||= do {
        my $ua = LWP::UserAgent->new;
        $ua->agent(join '/', $class, $class->VERSION);
        $ua->env_proxy;
        $ua;
    };

    my $req = HTTP::Request->new(GET => $uri);
    if ($HAS_ZLIB) {
        $req->header('Accept-Encoding', 'gzip');
    }
    if (my $etag = ($p_etag || $ref->{ETag})) {
        $req->header('If-None-Match', $etag);
    }
    if (my $ts = ($p_lastmod || $ref->{LastModified})) {
        $req->if_modified_since($ts);
    }

    my $res = $ua->request($req);
    my $fetch = URI::Fetch::Response->new;
    $fetch->uri($uri);
    $fetch->http_status($res->code);
    $fetch->http_response($res);
    $fetch->content_type($res->header('Content-Type'));
    if ($res->previous && $res->previous->code == HTTP::Status::RC_MOVED_PERMANENTLY()) {
        $fetch->status(URI_MOVED_PERMANENTLY);
        $fetch->uri($res->previous->header('Location'));
    } elsif ($res->code == HTTP::Status::RC_GONE()) {
        $fetch->status(URI_GONE);
        $fetch->uri(undef);
        return $fetch;
    } elsif ($res->code == HTTP::Status::RC_NOT_MODIFIED()) {
        $fetch->status(URI_NOT_MODIFIED);
        $fetch->content($ref->{Content});
        $fetch->etag($ref->{ETag});
        $fetch->last_modified($ref->{LastModified});
        $fetch->content_type($ref->{ContentType});
        return $fetch;
    } elsif (!$res->is_success) {
        return $force ? $fetch : $class->error($res->message);

    } else {
        $fetch->status(URI_OK);
    }
    $fetch->last_modified($res->last_modified);
    $fetch->etag($res->header('ETag'));
    my $content = $res->content;
    if ($res->content_encoding && $res->content_encoding eq 'gzip') {
        $content = Compress::Zlib::memGunzip($content);
    }

    # let caller-defined transform hook modify the result that'll be
    # cached.  perhaps the caller only wants the  section of
    # HTML, or wants to change the content to a parsed datastructure
    # already serialized with Storable.
    if ($content_hook) {
        croak("ContentAlterHook is not a subref") unless ref $content_hook eq "CODE";
        $content_hook->(\$content);
    }

    $fetch->content($content);

    # cache by default, if there's a cache.  but let callers cancel
    # the cache action by defining a cache grep hook
    if ($cache &&
        ($p_cache_grep ? $p_cache_grep->($fetch) : 1)) {

        $cache->set($uri, $freeze->({
            ETag         => $fetch->etag,
            LastModified => $fetch->last_modified,
            Content      => $fetch->content,
            CacheTime    => time(),
            ContentType  => $fetch->content_type,
        }));
    }
    $fetch;
}

1;
__END__