r19642 - in /trunk/liblwp-useragent-determined-perl: ./ ChangeLog MANIFEST MANIFEST.SKIP META.yml Makefile.PL README lib/ lib/LWP/ lib/LWP/UserAgent/ lib/LWP/UserAgent/Determined.pm t/ t/01_about_verbose.t t/10_determined_test.t
joeyh at users.alioth.debian.org
joeyh at users.alioth.debian.org
Wed May 7 22:53:14 UTC 2008
Author: joeyh
Date: Wed May 7 22:53:13 2008
New Revision: 19642
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=19642
Log:
injecting upstream source
This package is needed by libnet-amazon-s3-perl.
Added:
trunk/liblwp-useragent-determined-perl/
trunk/liblwp-useragent-determined-perl/ChangeLog
trunk/liblwp-useragent-determined-perl/MANIFEST
trunk/liblwp-useragent-determined-perl/MANIFEST.SKIP
trunk/liblwp-useragent-determined-perl/META.yml
trunk/liblwp-useragent-determined-perl/Makefile.PL
trunk/liblwp-useragent-determined-perl/README
trunk/liblwp-useragent-determined-perl/lib/
trunk/liblwp-useragent-determined-perl/lib/LWP/
trunk/liblwp-useragent-determined-perl/lib/LWP/UserAgent/
trunk/liblwp-useragent-determined-perl/lib/LWP/UserAgent/Determined.pm
trunk/liblwp-useragent-determined-perl/t/
trunk/liblwp-useragent-determined-perl/t/01_about_verbose.t
trunk/liblwp-useragent-determined-perl/t/10_determined_test.t
Added: trunk/liblwp-useragent-determined-perl/ChangeLog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/ChangeLog?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/ChangeLog (added)
+++ trunk/liblwp-useragent-determined-perl/ChangeLog Wed May 7 22:53:13 2008
@@ -1,0 +1,9 @@
+Revision history for Perl extension LWP::Determined::UserAgent
+ Time-stamp: "2004-04-08 23:10:29 ADT"
+
+
+2004-04-08 Sean M. Burke sburke at cpan.org
+ * Release 1.03 -- just a doc-typo bugfix version.
+
+2004-04-07 Sean M. Burke sburke at cpan.org
+ * Release 1.02 -- First public release.
Added: trunk/liblwp-useragent-determined-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/MANIFEST?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/MANIFEST (added)
+++ trunk/liblwp-useragent-determined-perl/MANIFEST Wed May 7 22:53:13 2008
@@ -1,0 +1,9 @@
+ChangeLog
+lib/LWP/UserAgent/Determined.pm
+Makefile.PL
+MANIFEST
+MANIFEST.SKIP
+README
+t/01_about_verbose.t
+t/10_determined_test.t
+META.yml Module meta-data (added by MakeMaker)
Added: trunk/liblwp-useragent-determined-perl/MANIFEST.SKIP
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/MANIFEST.SKIP?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/MANIFEST.SKIP (added)
+++ trunk/liblwp-useragent-determined-perl/MANIFEST.SKIP Wed May 7 22:53:13 2008
@@ -1,0 +1,8 @@
+^MANIFEST\.bak$
+^[-_a-zA-Z0-9]+[0-9]+\.[0-9]+(?:_[0-9]+)?$
+Makefile(\.old)?$
+t/.*.rtf$
+\.rej$
+CVS
+blib
+~
Added: trunk/liblwp-useragent-determined-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/META.yml?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/META.yml (added)
+++ trunk/liblwp-useragent-determined-perl/META.yml Wed May 7 22:53:13 2008
@@ -1,0 +1,11 @@
+# http://module-build.sourceforge.net/META-spec.html
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: LWP-UserAgent-Determined
+version: 1.03
+version_from: lib/LWP/UserAgent/Determined.pm
+installdirs: site
+requires:
+ LWP: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.17
Added: trunk/liblwp-useragent-determined-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/Makefile.PL?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/Makefile.PL (added)
+++ trunk/liblwp-useragent-determined-perl/Makefile.PL Wed May 7 22:53:13 2008
@@ -1,0 +1,32 @@
+
+# Run this program to generate a makefile. See "perldoc perlmodinstall"
+#
+# Time-stamp: "2004-04-08 22:47:11 ADT"
+#
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+
+require 5.004;
+use strict;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ 'NAME' => 'LWP::UserAgent::Determined',
+ 'VERSION_FROM' => 'lib/LWP/UserAgent/Determined.pm',
+ 'ABSTRACT_FROM' => 'lib/LWP/UserAgent/Determined.pm',
+ 'PREREQ_PM' => {
+ 'LWP' => 0,
+ },
+ 'dist' => { COMPRESS => 'gzip -6f', SUFFIX => 'gz', },
+);
+
+package MY;
+
+sub libscan
+{ # Determine things that should *not* be installed
+ my($self, $path) = @_;
+ return '' if $path =~ m/~/;
+ $path;
+}
+
+__END__
Added: trunk/liblwp-useragent-determined-perl/README
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/README?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/README (added)
+++ trunk/liblwp-useragent-determined-perl/README Wed May 7 22:53:13 2008
@@ -1,0 +1,84 @@
+README for LWP::UserAgent::Determined
+ Time-stamp: "2004-04-08 22:37:47 ADT"
+
+NAME
+
+LWP::UserAgent::Determined - a virtual browser that retries errors
+
+SYNOPSIS
+
+ use strict;
+ use LWP::UserAgent::Determined;
+ my $browser = LWP::UserAgent::Determined->new;
+ my $response = $browser->get($url, headers... );
+
+DESCRIPTION
+
+This class works just like LWP::UserAgent (and is based on it, by
+being a subclass of it), except that when you use it to get a web page
+but run into a possibly-temporary error (like a DNS lookup timeout),
+it'll wait a few seconds and retry a few times.
+
+It also adds some methods for controlling exactly what errors are
+considered retry-worthy and how many times to wait and for how many
+seconds, but normally you needn't bother about these, as the default
+settings are relatively sane.
+
+
+
+
+INSTALLATION
+
+You install this module, as you would install any perl module library,
+by running these commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+If you want to install a private copy of this module in your home
+directory, then you should try to produce the initial Makefile with
+something like this command:
+
+ perl Makefile.PL LIB=~/perl
+
+Then you may need something like
+ setenv PERLLIB "$HOME/perl"
+in your shell initialization file (e.g., ~/.cshrc).
+
+For further information, see perldoc perlmodinstall
+
+
+DOCUMENTATION
+
+POD-format documentation is included in this module. POD is readable
+with the 'perldoc' utility. See ChangeLog for recent changes.
+
+
+SUPPORT
+
+Questions, bug reports, useful code bits, and suggestions for
+this module should just be sent to me at sburke at cpan.org
+
+
+AVAILABILITY
+
+The latest version of this modules is available from the Comprehensive
+Perl Archive Network (CPAN). Visit <http://www.perl.com/CPAN/> to
+find a CPAN site near you.
+
+
+COPYRIGHT
+
+Copyright 2004, Sean M. Burke <sburke at cpan.org>, all rights reserved.
+This program is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful, but
+without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+AUTHOR
+
+Sean M. Burke <sburke at cpan.org>
Added: trunk/liblwp-useragent-determined-perl/lib/LWP/UserAgent/Determined.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/lib/LWP/UserAgent/Determined.pm?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/lib/LWP/UserAgent/Determined.pm (added)
+++ trunk/liblwp-useragent-determined-perl/lib/LWP/UserAgent/Determined.pm Wed May 7 22:53:13 2008
@@ -1,0 +1,243 @@
+
+package LWP::UserAgent::Determined;
+# Time-stamp: "2004-04-08 23:10:07 ADT" POD is at the end.
+$VERSION = '1.03';
+use LWP::UserAgent ();
+ at ISA = ('LWP::UserAgent');
+
+use strict;
+use LWP::Debug ();
+die "Where's _elem?!!?" unless __PACKAGE__->can('_elem');
+
+sub timing { shift->_elem('timing' , @_) }
+sub codes_to_determinate { shift->_elem('codes_to_determinate' , @_) }
+sub before_determined_callback { shift->_elem('before_determined_callback' , @_) }
+sub after_determined_callback { shift->_elem( 'after_determined_callback' , @_) }
+
+#==========================================================================
+
+sub simple_request {
+ my($self, @args) = @_;
+ LWP::Debug::trace('simple_request()');
+ my(@timing_tries) = ( $self->timing() =~ m<(\d+(?:\.\d+)*)>g );
+ my $determination = $self->codes_to_determinate();
+ LWP::Debug::debug("My retrial code policy is ["
+ . join(' ', sort keys %$determination) . "].");
+ LWP::Debug::debug("My retrial timing policy is [@timing_tries].");
+
+ my $resp;
+ my $before_c = $self->before_determined_callback;
+ my $after_c = $self->after_determined_callback;
+ foreach my $pause_if_unsuccessful (@timing_tries, undef) {
+ LWP::Debug::debug("Trying simple_request with args: ["
+ . join(',', map $_||"''", @args) . "]");
+
+ $before_c and $before_c->(
+ $self, \@timing_tries, $pause_if_unsuccessful, $determination, \@args);
+ $resp = $self->SUPER::simple_request(@args);
+ $after_c and $after_c->(
+ $self, \@timing_tries, $pause_if_unsuccessful, $determination, \@args, $resp);
+
+ my $code = $resp->code;
+ my $message = $resp->message;
+ $message =~ s/\s+$//s;
+ unless( $determination->{$code} ) { # normal case: all is well (or 404, etc)
+ LWP::Debug::debug("It returned a code ($code $message) blocking a retry");
+ return $resp;
+ }
+ if(defined $pause_if_unsuccessful) { # it's undef only on the last
+
+ LWP::Debug::debug("It returned a code ($code $message) that'll make me retry, after $pause_if_unsuccessful seconds.");
+ sleep $pause_if_unsuccessful if $pause_if_unsuccessful;
+ } else {
+ LWP::Debug::debug("I give up. I'm returning this \"$code $message\" response.");
+ }
+ }
+
+ return $resp;
+}
+
+#--------------------------------------------------------------------------
+
+sub new {
+ my $self = shift->SUPER::new(@_);
+ $self->_determined_init();
+ return $self;
+}
+
+#--------------------------------------------------------------------------
+
+sub _determined_init {
+ my $self = shift;
+ $self->timing( '1,3,15' );
+ $self->codes_to_determinate( { map $_=>1,
+ '408', # Request Timeout
+ '500', # Internal Server Error
+ '502', # Bad Gateway
+ '503', # Service Unavailable
+ '504', # Gateway Timeout
+ } );
+ return;
+}
+
+#==========================================================================
+
+1;
+__END__
+
+
+=head1 NAME
+
+LWP::UserAgent::Determined - a virtual browser that retries errors
+
+=head1 SYNOPSIS
+
+ use strict;
+ use LWP::UserAgent::Determined;
+ my $browser = LWP::UserAgent::Determined->new;
+ my $response = $browser->get($url, headers... );
+
+=head1 DESCRIPTION
+
+This class works just like L<LWP::UserAgent> (and is based on it, by
+being a subclass of it), except that when you use it to get a web page
+but run into a possibly-temporary error (like a DNS lookup timeout),
+it'll wait a few seconds and retry a few times.
+
+It also adds some methods for controlling exactly what errors are
+considered retry-worthy and how many times to wait and for how many
+seconds, but normally you needn't bother about these, as the default
+settings are relatively sane.
+
+=head1 METHODS
+
+This module inherits all of L<LWP::UserAgent>'s methods,
+and adds the following.
+
+=over
+
+=item $timing_string = $browser->timing();
+
+=item $browser->timing( "10,30,90" )
+
+The C<timing> method gets or sets the string that controls how many
+times it should retry, and how long the pauses should be.
+
+If you specify empty-string, this means not to retry at all.
+
+If you specify a string consisting of a single number, like "10", that
+means that if the first request doesn't succeed, then
+C<< $browser->get(...) >> (or any other method based on C<request>
+or C<simple_request>)
+should wait 10 seconds and try again (and if that fails, then
+it's final).
+
+If you specify a string with several numbers in it (like "10,30,90"),
+then that means C<$browser> can I<re>try as that many times (i.e., one
+initial try, I<plus> a maximum of the three retries, because three numbers
+there), and that it should wait first those numbers of seconds each time.
+So C<< $browser->timing( "10,30,90" ) >> basically means:
+
+ try the request; return it unless it's a temporary-looking error;
+ sleep 10;
+ retry the request; return it unless it's a temporary-looking error;
+ sleep 30;
+ retry the request; return it unless it's a temporary-looking error;
+ sleep 90 the request;
+ return it;
+
+The default value is "1,3,15".
+
+
+
+=item $http_codes_hr = $browser->codes_to_determinate();
+
+This returns the hash that is the set of HTTP codes that merit a retry
+(like 500 and 408, but unlike 404 or 200). You can delete or add
+entries like so;
+
+ $http_codes_hr = $browser->codes_to_determinate();
+ delete $http_codes_hr->{408};
+ $http_codes_hr->{567} = 1;
+
+(You can actually set a whole new hashset with C<<
+$browser->codes_to_determinate($new_hr) >>, but there's usually no
+benefit to that as opposed to the above.)
+
+The current default is 408 (Timeout) plus some 5xx codes.
+
+
+
+=item $browser->before_determined_callback()
+
+=item $browser->before_determined_callback( \&some_routine );
+
+=item $browser->after_determined_callback()
+
+=item $browser->after_determined_callback( \&some_routine );
+
+These read (first two) or set (second two) callbacks that are
+called before the actual HTTP/FTP/etc request is made. By default,
+these are set to undef, meaning nothing special is called. If you
+want to alter try requests, or inspect responses before any retrying
+is considered, you can set up these callbacks.
+
+The arguments passed to these routines are:
+
+=over
+
+=item 0: the current $browser object
+
+=item 1: an arrayref to the list of timing pauses (based on $browser->timing)
+
+=item 2: the duration of the number of seconds we'll pause if this request
+fails this time, or undef if this is the last chance.
+
+=item 3: the value of $browser->codes_to_determinate
+
+=item 4: an arrayref of the arguments we pass to LWP::UserAgent::simple_request
+(the first of which is the request object)
+
+=item (5): And, only for after_determined_callback, the response we
+just got.
+
+=back
+
+Example use:
+
+ $browser->before_determined_callback( sub {
+ print "Trying ", $_[4][0]->uri, " ...\n";
+ });
+
+=back
+
+
+=head1 IMPLEMENTATION
+
+This class works by overriding LWP::UserAgent's C<simple_request> method
+with its own around-method that just loops. See the source of this
+module; it's straightforward. Relatively.
+
+
+=head1 SEE ALSO
+
+L<LWP>, L<LWP::UserAgent>
+
+
+=head1 COPYRIGHT AND DISCLAIMER
+
+Copyright 2004, Sean M. Burke C<sburke at cpan.org>, all rights
+reserved. This program is free software; you can redistribute it
+and/or modify it under the same terms as Perl itself.
+
+This program is distributed in the hope that it will be useful,
+but without any warranty; without even the implied warranty of
+merchantability or fitness for a particular purpose.
+
+
+=head1 AUTHOR
+
+Sean M. Burke, C<sburke at cpan.org>
+
+=cut
+
Added: trunk/liblwp-useragent-determined-perl/t/01_about_verbose.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/t/01_about_verbose.t?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/t/01_about_verbose.t (added)
+++ trunk/liblwp-useragent-determined-perl/t/01_about_verbose.t Wed May 7 22:53:13 2008
@@ -1,0 +1,89 @@
+
+require 5;
+# Time-stamp: "2004-04-08 22:47:53 ADT"
+
+# Summary of, well, things.
+
+use Test;
+BEGIN {plan tests => 2};
+
+ok 1;
+
+use LWP::UserAgent::Determined;
+use LWP::UserAgent;
+use LWP;
+
+#chdir "t" if -e "t";
+
+{
+ my @out;
+ push @out,
+ "\n\nPerl v",
+ defined($^V) ? sprintf('%vd', $^V) : $],
+ " under $^O ",
+ (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
+ ? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (),
+ (defined $MacPerl::Version)
+ ? ("(MacPerl version $MacPerl::Version)") : (),
+ "\n"
+ ;
+
+ # Ugly code to walk the symbol tables:
+ my %v;
+ my @stack = (''); # start out in %::
+ my $this;
+ my $count = 0;
+ my $pref;
+ while(@stack) {
+ $this = shift @stack;
+ die "Too many packages?" if ++$count > 1000;
+ next if exists $v{$this};
+ next if $this eq 'main'; # %main:: is %::
+
+ #print "Peeking at $this => ${$this . '::VERSION'}\n";
+
+ if(defined ${$this . '::VERSION'} ) {
+ $v{$this} = ${$this . '::VERSION'}
+ } elsif(
+ defined *{$this . '::ISA'} or defined &{$this . '::import'}
+ or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"})
+ # If it has an ISA, an import, or any subs...
+ ) {
+ # It's a class/module with no version.
+ $v{$this} = undef;
+ } else {
+ # It's probably an unpopulated package.
+ ## $v{$this} = '...';
+ }
+
+ $pref = length($this) ? "$this\::" : '';
+ push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'};
+ #print "Stack: @stack\n";
+ }
+ push @out, " Modules in memory:\n";
+ delete @v{'', '[none]'};
+ foreach my $p (sort {lc($a) cmp lc($b)} keys %v) {
+ $indent = ' ' x (2 + ($p =~ tr/:/:/));
+ push @out, ' ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n";
+ }
+ push @out, sprintf "[at %s (local) / %s (GMT)]\n",
+ scalar(gmtime), scalar(localtime);
+ my $x = join '', @out;
+ $x =~ s/^/#/mg;
+ print $x;
+}
+
+print "# Running",
+ (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n",
+ "#\n",
+;
+
+print "# \@INC:\n", map("# [$_]\n", @INC), "#\n#\n";
+
+print "# \%INC:\n";
+foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) {
+ print "# [$x] = [", $INC{$x} || '', "]\n";
+}
+
+ok 1;
+
Added: trunk/liblwp-useragent-determined-perl/t/10_determined_test.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/liblwp-useragent-determined-perl/t/10_determined_test.t?rev=19642&op=file
==============================================================================
--- trunk/liblwp-useragent-determined-perl/t/10_determined_test.t (added)
+++ trunk/liblwp-useragent-determined-perl/t/10_determined_test.t Wed May 7 22:53:13 2008
@@ -1,0 +1,87 @@
+
+# Time-stamp: "0";
+use strict;
+use Test;
+BEGIN { plan tests => 11 }
+
+#use LWP::Debug ('+');
+
+use LWP::UserAgent::Determined;
+my $browser = LWP::UserAgent::Determined->new;
+
+#$browser->agent('Mozilla/4.76 [en] (Win98; U)');
+
+ok 1;
+print "# Hello from ", __FILE__, "\n";
+print "# LWP::UserAgent::Determined v$LWP::UserAgent::Determined::VERSION\n";
+print "# LWP::UserAgent v$LWP::UserAgent::VERSION\n";
+print "# LWP v$LWP::VERSION\n" if $LWP::VERSION;
+
+my $url = 'http://www.livejournal.com/~torgo_x/rss';
+my $before_count = 0;
+my $after_count = 0;
+
+$browser->before_determined_callback( sub {
+ print "# /Trying ", $_[4][0]->uri, " at ", scalar(localtime), "...\n";
+ ++$before_count;
+});
+$browser->after_determined_callback( sub {
+ print "# \\Just tried ", $_[4][0]->uri, " at ", scalar(localtime), ".\n";
+ ++$after_count;
+});
+
+my $resp = $browser->get( $url );
+ok 1;
+
+print "# That gave: ", $resp->status_line, "\n";
+print "# Before_count: $before_count\n";
+ok( $before_count > 1 );
+print "# After_count: $after_count\n";
+ok( $after_count > 1 );
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+$url = "http://www.aoeaoeaoeaoe.int:9876/sntstn";
+$before_count = 0;
+ $after_count = 0;
+
+print "# Trying a nonexistent address, $url\n";
+
+$resp = $browser->get( $url );
+ok 1;
+
+$browser->timing('1,2,3');
+print "# Timing: ", $browser->timing, "\n";
+
+print "# That gave: ", $resp->status_line, "\n";
+print "# Before_count: $before_count\n";
+ok $before_count, 4;
+print "# After_count: $after_count\n";
+ok $after_count, 4;
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+$url = "http://www.interglacial.com/always404alicious/";
+$before_count = 0;
+ $after_count = 0;
+
+print "# Trying a nonexistent address, $url\n";
+
+$resp = $browser->get( $url );
+ok 1;
+
+$browser->timing('1,2,3');
+print "# Timing: ", $browser->timing, "\n";
+
+print "# That gave: ", $resp->status_line, "\n";
+print "# Before_count: $before_count\n";
+ok $before_count, 1;
+print "# After_count: $after_count\n";
+ok $after_count, 1;
+
+
+# - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+print "# Okay, bye from ", __FILE__, "\n";
+ok 1;
+
More information about the Pkg-perl-cvs-commits
mailing list