From ee4d87281ff498b5491e5ab06684379198ace86b Mon Sep 17 00:00:00 2001 From: franck cuny Date: Fri, 17 Jul 2009 17:17:54 +0200 Subject: up --- lib/MooseX/UserAgent.pm | 21 +----------- lib/MooseX/UserAgent/Async.pm | 1 + lib/MooseX/UserAgent/Cache.pm | 1 + lib/MooseX/UserAgent/Config.pm | 21 ++++++++---- lib/MooseX/UserAgent/Content.pm | 1 + lib/MooseX/UserAgent/Generic.pm | 30 +++++++++++++++++ lib/MooseX/UserAgent/Paranoid.pm | 72 ++++++++++++++++++++++++++++++---------- 7 files changed, 103 insertions(+), 44 deletions(-) create mode 100644 lib/MooseX/UserAgent/Generic.pm (limited to 'lib/MooseX') diff --git a/lib/MooseX/UserAgent.pm b/lib/MooseX/UserAgent.pm index 58ee83f..cc589bc 100644 --- a/lib/MooseX/UserAgent.pm +++ b/lib/MooseX/UserAgent.pm @@ -2,35 +2,16 @@ package MooseX::UserAgent; our $VERSION = '0.2.0'; -use URI; -use HTTP::Request; -use HTTP::Response; -use LWP::UserAgent; - use Moose::Role; with qw/ MooseX::UserAgent::Config MooseX::UserAgent::Content MooseX::UserAgent::Cache + MooseX::UserAgent::Generic /; has _LWPLIB => ( isa => 'Str', is => 'ro', default => 'LWP::UserAgent' ); -sub fetch { - my ( $self, $url ) = @_; - - my $req = HTTP::Request->new( GET => URI->new($url) ); - - $req->header( 'Accept-Encoding', 'gzip' ); - my $last_modified = $self->get_ua_cache($url); - $req->header( 'If-Modified-Since' => $last_modified ) - if $last_modified; - - my $res = $self->agent->request($req); - $self->store_ua_cache( $url, $res ); - $res; -} - 1; __END__ diff --git a/lib/MooseX/UserAgent/Async.pm b/lib/MooseX/UserAgent/Async.pm index b00cc73..8d68384 100644 --- a/lib/MooseX/UserAgent/Async.pm +++ b/lib/MooseX/UserAgent/Async.pm @@ -90,6 +90,7 @@ franck cuny C<< >> Copyright (c) 2009, RTGI All rights reserved. +L This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. diff --git a/lib/MooseX/UserAgent/Cache.pm b/lib/MooseX/UserAgent/Cache.pm index b5fff18..36be242 100644 --- a/lib/MooseX/UserAgent/Cache.pm +++ b/lib/MooseX/UserAgent/Cache.pm @@ -62,6 +62,7 @@ franck cuny C<< >> Copyright (c) 2009, RTGI All rights reserved. +L This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. diff --git a/lib/MooseX/UserAgent/Config.pm b/lib/MooseX/UserAgent/Config.pm index cf453b0..d31a4dd 100644 --- a/lib/MooseX/UserAgent/Config.pm +++ b/lib/MooseX/UserAgent/Config.pm @@ -1,23 +1,29 @@ package MooseX::UserAgent::Config; use Moose::Role; +use Carp qw/croak/; has 'agent' => ( isa => 'Object', is => 'rw', lazy => 1, default => sub { - my $self = shift; - my $ua = $self->_LWPLIB->new; + my $self = shift; + my $class = $self->_LWPLIB; + eval " require $class "; + if ($@) { + croak "can't load " . $self->_LWPLIB . " : " . $@; + } + my $ua = $self->_LWPLIB->new; - if (!$self->can('useragent_conf')) { - # TODO + if ( !$self->can('useragent_conf') ) { + croak "no useragent_conf"; } my $conf = $self->useragent_conf; - $ua->agent( $conf->{name} ) if $conf->{name}; - $ua->from( $conf->{mail} ) if $conf->{mail}; + $ua->agent( $conf->{name} ) if $conf->{name}; + $ua->from( $conf->{mail} ) if $conf->{mail}; $ua->max_size( $conf->{max_size} ) if $conf->{max_size}; - $ua->timeout( $conf->{timeout} || 180 ); + $ua->timeout( $conf->{timeout} || 180 ); $ua; } ); @@ -107,6 +113,7 @@ franck cuny C<< >> Copyright (c) 2009, RTGI All rights reserved. +L This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. diff --git a/lib/MooseX/UserAgent/Content.pm b/lib/MooseX/UserAgent/Content.pm index 653b5d9..66dfa41 100644 --- a/lib/MooseX/UserAgent/Content.pm +++ b/lib/MooseX/UserAgent/Content.pm @@ -44,6 +44,7 @@ franck cuny C<< >> Copyright (c) 2009, RTGI All rights reserved. +L This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L. diff --git a/lib/MooseX/UserAgent/Generic.pm b/lib/MooseX/UserAgent/Generic.pm new file mode 100644 index 0000000..dd1966f --- /dev/null +++ b/lib/MooseX/UserAgent/Generic.pm @@ -0,0 +1,30 @@ +package MooseX::UserAgent::Generic; + +our $VERSION = '0.2.0'; + +use URI; +use HTTP::Request; + +use Moose::Role; +with qw/ + MooseX::UserAgent::Config + MooseX::UserAgent::Content + MooseX::UserAgent::Cache + /; + +sub fetch { + my ( $self, $url ) = @_; + + my $req = HTTP::Request->new( GET => URI->new($url) ); + + $req->header( 'Accept-Encoding', 'gzip' ); + my $last_modified = $self->get_ua_cache($url); + $req->header( 'If-Modified-Since' => $last_modified ) + if $last_modified; + + my $res = $self->agent->request($req); + $self->store_ua_cache( $url, $res ); + $res; +} + +1; diff --git a/lib/MooseX/UserAgent/Paranoid.pm b/lib/MooseX/UserAgent/Paranoid.pm index 61dab94..b33b157 100644 --- a/lib/MooseX/UserAgent/Paranoid.pm +++ b/lib/MooseX/UserAgent/Paranoid.pm @@ -1,32 +1,70 @@ package MooseX::UserAgent::Paranoid; -use URI; -use HTTP::Request; -use HTTP::Response; -use LWPx::ParanoidAgent; - use Moose::Role; with qw/ MooseX::UserAgent::Config MooseX::UserAgent::Content MooseX::UserAgent::Cache + MooseX::UserAgent::Generic /; has _LWPLIB => ( isa => 'Str', is => 'ro', default => 'LWPx::ParanoidAgent' ); -sub fetch { - my ( $self, $url ) = @_; +1; - my $req = HTTP::Request->new( GET => URI->new($url) ); +__END__ - $req->header( 'Accept-Encoding', 'gzip' ); - my $last_modified = $self->get_ua_cache($url); - $req->header( 'If-Modified-Since' => $last_modified ) - if $last_modified; +=head1 NAME - my $res = $self->agent->request($req); - $self->store_ua_cache( $url, $res ); - $res; -} +RTGI::Role::UserAgent::Paranoid - Fetch an url using LWPx::ParanoidAgent -1; +=head1 SYNOPSIS + + package Foo; + + use Moose; + with qw/MooseX::UserAgent::Paranoid/; + + has useragent_conf => ( + isa => 'HashRef', + default => sub { + { name => 'myownbot', }; + } + ); + + my $res = $self->fetch($url, $cache); + ... + my $content = $self->get_content($res); + +=head1 DESCRIPTION + +=head2 METHODS + +=over 4 + +=item B + +This method will fetch a given URL. This method handle only the http +protocol. + +If there is a cache configuration, the url will be checked in the cache, +and if there is a match, a 304 HTTP code will be returned. + +Return a HTTP::Response object. + +=back + +=head1 BUGS AND LIMITATIONS + +=head1 AUTHOR + +franck cuny C<< >> + +=head1 LICENCE AND COPYRIGHT + +Copyright (c) 2009, RTGI +All rights reserved. +L + +This module is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. See L. -- cgit 1.4.1