Codebase list liblwp-useragent-determined-perl / 609981e
injecting upstream source This package is needed by libnet-amazon-s3-perl. Joey Hess 16 years ago
9 changed file(s) with 572 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+9
-0
ChangeLog less more
0 Revision history for Perl extension LWP::Determined::UserAgent
1 Time-stamp: "2004-04-08 23:10:29 ADT"
2
3
4 2004-04-08 Sean M. Burke sburke@cpan.org
5 * Release 1.03 -- just a doc-typo bugfix version.
6
7 2004-04-07 Sean M. Burke sburke@cpan.org
8 * Release 1.02 -- First public release.
+9
-0
MANIFEST less more
0 ChangeLog
1 lib/LWP/UserAgent/Determined.pm
2 Makefile.PL
3 MANIFEST
4 MANIFEST.SKIP
5 README
6 t/01_about_verbose.t
7 t/10_determined_test.t
8 META.yml Module meta-data (added by MakeMaker)
+8
-0
MANIFEST.SKIP less more
0 ^MANIFEST\.bak$
1 ^[-_a-zA-Z0-9]+[0-9]+\.[0-9]+(?:_[0-9]+)?$
2 Makefile(\.old)?$
3 t/.*.rtf$
4 \.rej$
5 CVS
6 blib
7 ~
+11
-0
META.yml less more
0 # http://module-build.sourceforge.net/META-spec.html
1 #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
2 name: LWP-UserAgent-Determined
3 version: 1.03
4 version_from: lib/LWP/UserAgent/Determined.pm
5 installdirs: site
6 requires:
7 LWP: 0
8
9 distribution_type: module
10 generated_by: ExtUtils::MakeMaker version 6.17
+32
-0
Makefile.PL less more
0
1 # Run this program to generate a makefile. See "perldoc perlmodinstall"
2 #
3 # Time-stamp: "2004-04-08 22:47:11 ADT"
4 #
5 # See lib/ExtUtils/MakeMaker.pm for details of how to influence
6 # the contents of the Makefile that is written.
7
8 require 5.004;
9 use strict;
10 use ExtUtils::MakeMaker;
11
12 WriteMakefile(
13 'NAME' => 'LWP::UserAgent::Determined',
14 'VERSION_FROM' => 'lib/LWP/UserAgent/Determined.pm',
15 'ABSTRACT_FROM' => 'lib/LWP/UserAgent/Determined.pm',
16 'PREREQ_PM' => {
17 'LWP' => 0,
18 },
19 'dist' => { COMPRESS => 'gzip -6f', SUFFIX => 'gz', },
20 );
21
22 package MY;
23
24 sub libscan
25 { # Determine things that should *not* be installed
26 my($self, $path) = @_;
27 return '' if $path =~ m/~/;
28 $path;
29 }
30
31 __END__
+84
-0
README less more
0 README for LWP::UserAgent::Determined
1 Time-stamp: "2004-04-08 22:37:47 ADT"
2
3 NAME
4
5 LWP::UserAgent::Determined - a virtual browser that retries errors
6
7 SYNOPSIS
8
9 use strict;
10 use LWP::UserAgent::Determined;
11 my $browser = LWP::UserAgent::Determined->new;
12 my $response = $browser->get($url, headers... );
13
14 DESCRIPTION
15
16 This class works just like LWP::UserAgent (and is based on it, by
17 being a subclass of it), except that when you use it to get a web page
18 but run into a possibly-temporary error (like a DNS lookup timeout),
19 it'll wait a few seconds and retry a few times.
20
21 It also adds some methods for controlling exactly what errors are
22 considered retry-worthy and how many times to wait and for how many
23 seconds, but normally you needn't bother about these, as the default
24 settings are relatively sane.
25
26
27
28
29 INSTALLATION
30
31 You install this module, as you would install any perl module library,
32 by running these commands:
33
34 perl Makefile.PL
35 make
36 make test
37 make install
38
39 If you want to install a private copy of this module in your home
40 directory, then you should try to produce the initial Makefile with
41 something like this command:
42
43 perl Makefile.PL LIB=~/perl
44
45 Then you may need something like
46 setenv PERLLIB "$HOME/perl"
47 in your shell initialization file (e.g., ~/.cshrc).
48
49 For further information, see perldoc perlmodinstall
50
51
52 DOCUMENTATION
53
54 POD-format documentation is included in this module. POD is readable
55 with the 'perldoc' utility. See ChangeLog for recent changes.
56
57
58 SUPPORT
59
60 Questions, bug reports, useful code bits, and suggestions for
61 this module should just be sent to me at sburke@cpan.org
62
63
64 AVAILABILITY
65
66 The latest version of this modules is available from the Comprehensive
67 Perl Archive Network (CPAN). Visit <http://www.perl.com/CPAN/> to
68 find a CPAN site near you.
69
70
71 COPYRIGHT
72
73 Copyright 2004, Sean M. Burke <sburke@cpan.org>, all rights reserved.
74 This program is free software; you can redistribute it and/or modify
75 it under the same terms as Perl itself.
76
77 This program is distributed in the hope that it will be useful, but
78 without any warranty; without even the implied warranty of
79 merchantability or fitness for a particular purpose.
80
81 AUTHOR
82
83 Sean M. Burke <sburke@cpan.org>
+243
-0
lib/LWP/UserAgent/Determined.pm less more
0
1 package LWP::UserAgent::Determined;
2 # Time-stamp: "2004-04-08 23:10:07 ADT" POD is at the end.
3 $VERSION = '1.03';
4 use LWP::UserAgent ();
5 @ISA = ('LWP::UserAgent');
6
7 use strict;
8 use LWP::Debug ();
9 die "Where's _elem?!!?" unless __PACKAGE__->can('_elem');
10
11 sub timing { shift->_elem('timing' , @_) }
12 sub codes_to_determinate { shift->_elem('codes_to_determinate' , @_) }
13 sub before_determined_callback { shift->_elem('before_determined_callback' , @_) }
14 sub after_determined_callback { shift->_elem( 'after_determined_callback' , @_) }
15
16 #==========================================================================
17
18 sub simple_request {
19 my($self, @args) = @_;
20 LWP::Debug::trace('simple_request()');
21 my(@timing_tries) = ( $self->timing() =~ m<(\d+(?:\.\d+)*)>g );
22 my $determination = $self->codes_to_determinate();
23 LWP::Debug::debug("My retrial code policy is ["
24 . join(' ', sort keys %$determination) . "].");
25 LWP::Debug::debug("My retrial timing policy is [@timing_tries].");
26
27 my $resp;
28 my $before_c = $self->before_determined_callback;
29 my $after_c = $self->after_determined_callback;
30 foreach my $pause_if_unsuccessful (@timing_tries, undef) {
31 LWP::Debug::debug("Trying simple_request with args: ["
32 . join(',', map $_||"''", @args) . "]");
33
34 $before_c and $before_c->(
35 $self, \@timing_tries, $pause_if_unsuccessful, $determination, \@args);
36 $resp = $self->SUPER::simple_request(@args);
37 $after_c and $after_c->(
38 $self, \@timing_tries, $pause_if_unsuccessful, $determination, \@args, $resp);
39
40 my $code = $resp->code;
41 my $message = $resp->message;
42 $message =~ s/\s+$//s;
43 unless( $determination->{$code} ) { # normal case: all is well (or 404, etc)
44 LWP::Debug::debug("It returned a code ($code $message) blocking a retry");
45 return $resp;
46 }
47 if(defined $pause_if_unsuccessful) { # it's undef only on the last
48
49 LWP::Debug::debug("It returned a code ($code $message) that'll make me retry, after $pause_if_unsuccessful seconds.");
50 sleep $pause_if_unsuccessful if $pause_if_unsuccessful;
51 } else {
52 LWP::Debug::debug("I give up. I'm returning this \"$code $message\" response.");
53 }
54 }
55
56 return $resp;
57 }
58
59 #--------------------------------------------------------------------------
60
61 sub new {
62 my $self = shift->SUPER::new(@_);
63 $self->_determined_init();
64 return $self;
65 }
66
67 #--------------------------------------------------------------------------
68
69 sub _determined_init {
70 my $self = shift;
71 $self->timing( '1,3,15' );
72 $self->codes_to_determinate( { map $_=>1,
73 '408', # Request Timeout
74 '500', # Internal Server Error
75 '502', # Bad Gateway
76 '503', # Service Unavailable
77 '504', # Gateway Timeout
78 } );
79 return;
80 }
81
82 #==========================================================================
83
84 1;
85 __END__
86
87
88 =head1 NAME
89
90 LWP::UserAgent::Determined - a virtual browser that retries errors
91
92 =head1 SYNOPSIS
93
94 use strict;
95 use LWP::UserAgent::Determined;
96 my $browser = LWP::UserAgent::Determined->new;
97 my $response = $browser->get($url, headers... );
98
99 =head1 DESCRIPTION
100
101 This class works just like L<LWP::UserAgent> (and is based on it, by
102 being a subclass of it), except that when you use it to get a web page
103 but run into a possibly-temporary error (like a DNS lookup timeout),
104 it'll wait a few seconds and retry a few times.
105
106 It also adds some methods for controlling exactly what errors are
107 considered retry-worthy and how many times to wait and for how many
108 seconds, but normally you needn't bother about these, as the default
109 settings are relatively sane.
110
111 =head1 METHODS
112
113 This module inherits all of L<LWP::UserAgent>'s methods,
114 and adds the following.
115
116 =over
117
118 =item $timing_string = $browser->timing();
119
120 =item $browser->timing( "10,30,90" )
121
122 The C<timing> method gets or sets the string that controls how many
123 times it should retry, and how long the pauses should be.
124
125 If you specify empty-string, this means not to retry at all.
126
127 If you specify a string consisting of a single number, like "10", that
128 means that if the first request doesn't succeed, then
129 C<< $browser->get(...) >> (or any other method based on C<request>
130 or C<simple_request>)
131 should wait 10 seconds and try again (and if that fails, then
132 it's final).
133
134 If you specify a string with several numbers in it (like "10,30,90"),
135 then that means C<$browser> can I<re>try as that many times (i.e., one
136 initial try, I<plus> a maximum of the three retries, because three numbers
137 there), and that it should wait first those numbers of seconds each time.
138 So C<< $browser->timing( "10,30,90" ) >> basically means:
139
140 try the request; return it unless it's a temporary-looking error;
141 sleep 10;
142 retry the request; return it unless it's a temporary-looking error;
143 sleep 30;
144 retry the request; return it unless it's a temporary-looking error;
145 sleep 90 the request;
146 return it;
147
148 The default value is "1,3,15".
149
150
151
152 =item $http_codes_hr = $browser->codes_to_determinate();
153
154 This returns the hash that is the set of HTTP codes that merit a retry
155 (like 500 and 408, but unlike 404 or 200). You can delete or add
156 entries like so;
157
158 $http_codes_hr = $browser->codes_to_determinate();
159 delete $http_codes_hr->{408};
160 $http_codes_hr->{567} = 1;
161
162 (You can actually set a whole new hashset with C<<
163 $browser->codes_to_determinate($new_hr) >>, but there's usually no
164 benefit to that as opposed to the above.)
165
166 The current default is 408 (Timeout) plus some 5xx codes.
167
168
169
170 =item $browser->before_determined_callback()
171
172 =item $browser->before_determined_callback( \&some_routine );
173
174 =item $browser->after_determined_callback()
175
176 =item $browser->after_determined_callback( \&some_routine );
177
178 These read (first two) or set (second two) callbacks that are
179 called before the actual HTTP/FTP/etc request is made. By default,
180 these are set to undef, meaning nothing special is called. If you
181 want to alter try requests, or inspect responses before any retrying
182 is considered, you can set up these callbacks.
183
184 The arguments passed to these routines are:
185
186 =over
187
188 =item 0: the current $browser object
189
190 =item 1: an arrayref to the list of timing pauses (based on $browser->timing)
191
192 =item 2: the duration of the number of seconds we'll pause if this request
193 fails this time, or undef if this is the last chance.
194
195 =item 3: the value of $browser->codes_to_determinate
196
197 =item 4: an arrayref of the arguments we pass to LWP::UserAgent::simple_request
198 (the first of which is the request object)
199
200 =item (5): And, only for after_determined_callback, the response we
201 just got.
202
203 =back
204
205 Example use:
206
207 $browser->before_determined_callback( sub {
208 print "Trying ", $_[4][0]->uri, " ...\n";
209 });
210
211 =back
212
213
214 =head1 IMPLEMENTATION
215
216 This class works by overriding LWP::UserAgent's C<simple_request> method
217 with its own around-method that just loops. See the source of this
218 module; it's straightforward. Relatively.
219
220
221 =head1 SEE ALSO
222
223 L<LWP>, L<LWP::UserAgent>
224
225
226 =head1 COPYRIGHT AND DISCLAIMER
227
228 Copyright 2004, Sean M. Burke C<sburke@cpan.org>, all rights
229 reserved. This program is free software; you can redistribute it
230 and/or modify it under the same terms as Perl itself.
231
232 This program is distributed in the hope that it will be useful,
233 but without any warranty; without even the implied warranty of
234 merchantability or fitness for a particular purpose.
235
236
237 =head1 AUTHOR
238
239 Sean M. Burke, C<sburke@cpan.org>
240
241 =cut
242
+89
-0
t/01_about_verbose.t less more
0
1 require 5;
2 # Time-stamp: "2004-04-08 22:47:53 ADT"
3
4 # Summary of, well, things.
5
6 use Test;
7 BEGIN {plan tests => 2};
8
9 ok 1;
10
11 use LWP::UserAgent::Determined;
12 use LWP::UserAgent;
13 use LWP;
14
15 #chdir "t" if -e "t";
16
17 {
18 my @out;
19 push @out,
20 "\n\nPerl v",
21 defined($^V) ? sprintf('%vd', $^V) : $],
22 " under $^O ",
23 (defined(&Win32::BuildNumber) and defined &Win32::BuildNumber())
24 ? ("(Win32::BuildNumber ", &Win32::BuildNumber(), ")") : (),
25 (defined $MacPerl::Version)
26 ? ("(MacPerl version $MacPerl::Version)") : (),
27 "\n"
28 ;
29
30 # Ugly code to walk the symbol tables:
31 my %v;
32 my @stack = (''); # start out in %::
33 my $this;
34 my $count = 0;
35 my $pref;
36 while(@stack) {
37 $this = shift @stack;
38 die "Too many packages?" if ++$count > 1000;
39 next if exists $v{$this};
40 next if $this eq 'main'; # %main:: is %::
41
42 #print "Peeking at $this => ${$this . '::VERSION'}\n";
43
44 if(defined ${$this . '::VERSION'} ) {
45 $v{$this} = ${$this . '::VERSION'}
46 } elsif(
47 defined *{$this . '::ISA'} or defined &{$this . '::import'}
48 or ($this ne '' and grep defined *{$_}{'CODE'}, values %{$this . "::"})
49 # If it has an ISA, an import, or any subs...
50 ) {
51 # It's a class/module with no version.
52 $v{$this} = undef;
53 } else {
54 # It's probably an unpopulated package.
55 ## $v{$this} = '...';
56 }
57
58 $pref = length($this) ? "$this\::" : '';
59 push @stack, map m/^(.+)::$/ ? "$pref$1" : (), keys %{$this . '::'};
60 #print "Stack: @stack\n";
61 }
62 push @out, " Modules in memory:\n";
63 delete @v{'', '[none]'};
64 foreach my $p (sort {lc($a) cmp lc($b)} keys %v) {
65 $indent = ' ' x (2 + ($p =~ tr/:/:/));
66 push @out, ' ', $indent, $p, defined($v{$p}) ? " v$v{$p};\n" : ";\n";
67 }
68 push @out, sprintf "[at %s (local) / %s (GMT)]\n",
69 scalar(gmtime), scalar(localtime);
70 my $x = join '', @out;
71 $x =~ s/^/#/mg;
72 print $x;
73 }
74
75 print "# Running",
76 (chr(65) eq 'A') ? " in an ASCII world.\n" : " in a non-ASCII world.\n",
77 "#\n",
78 ;
79
80 print "# \@INC:\n", map("# [$_]\n", @INC), "#\n#\n";
81
82 print "# \%INC:\n";
83 foreach my $x (sort {lc($a) cmp lc($b)} keys %INC) {
84 print "# [$x] = [", $INC{$x} || '', "]\n";
85 }
86
87 ok 1;
88
+87
-0
t/10_determined_test.t less more
0
1 # Time-stamp: "0";
2 use strict;
3 use Test;
4 BEGIN { plan tests => 11 }
5
6 #use LWP::Debug ('+');
7
8 use LWP::UserAgent::Determined;
9 my $browser = LWP::UserAgent::Determined->new;
10
11 #$browser->agent('Mozilla/4.76 [en] (Win98; U)');
12
13 ok 1;
14 print "# Hello from ", __FILE__, "\n";
15 print "# LWP::UserAgent::Determined v$LWP::UserAgent::Determined::VERSION\n";
16 print "# LWP::UserAgent v$LWP::UserAgent::VERSION\n";
17 print "# LWP v$LWP::VERSION\n" if $LWP::VERSION;
18
19 my $url = 'http://www.livejournal.com/~torgo_x/rss';
20 my $before_count = 0;
21 my $after_count = 0;
22
23 $browser->before_determined_callback( sub {
24 print "# /Trying ", $_[4][0]->uri, " at ", scalar(localtime), "...\n";
25 ++$before_count;
26 });
27 $browser->after_determined_callback( sub {
28 print "# \\Just tried ", $_[4][0]->uri, " at ", scalar(localtime), ".\n";
29 ++$after_count;
30 });
31
32 my $resp = $browser->get( $url );
33 ok 1;
34
35 print "# That gave: ", $resp->status_line, "\n";
36 print "# Before_count: $before_count\n";
37 ok( $before_count > 1 );
38 print "# After_count: $after_count\n";
39 ok( $after_count > 1 );
40
41 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
42
43 $url = "http://www.aoeaoeaoeaoe.int:9876/sntstn";
44 $before_count = 0;
45 $after_count = 0;
46
47 print "# Trying a nonexistent address, $url\n";
48
49 $resp = $browser->get( $url );
50 ok 1;
51
52 $browser->timing('1,2,3');
53 print "# Timing: ", $browser->timing, "\n";
54
55 print "# That gave: ", $resp->status_line, "\n";
56 print "# Before_count: $before_count\n";
57 ok $before_count, 4;
58 print "# After_count: $after_count\n";
59 ok $after_count, 4;
60
61
62 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
63
64 $url = "http://www.interglacial.com/always404alicious/";
65 $before_count = 0;
66 $after_count = 0;
67
68 print "# Trying a nonexistent address, $url\n";
69
70 $resp = $browser->get( $url );
71 ok 1;
72
73 $browser->timing('1,2,3');
74 print "# Timing: ", $browser->timing, "\n";
75
76 print "# That gave: ", $resp->status_line, "\n";
77 print "# Before_count: $before_count\n";
78 ok $before_count, 1;
79 print "# After_count: $after_count\n";
80 ok $after_count, 1;
81
82
83 # - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
84 print "# Okay, bye from ", __FILE__, "\n";
85 ok 1;
86