1 | package LWP::Protocol;
|
---|
2 |
|
---|
3 | require LWP::MemberMixin;
|
---|
4 | @ISA = qw(LWP::MemberMixin);
|
---|
5 | $VERSION = "5.829";
|
---|
6 |
|
---|
7 | use strict;
|
---|
8 | use Carp ();
|
---|
9 | use HTTP::Status ();
|
---|
10 | use HTTP::Response;
|
---|
11 |
|
---|
12 | my %ImplementedBy = (); # scheme => classname
|
---|
13 |
|
---|
14 |
|
---|
15 |
|
---|
16 | sub new
|
---|
17 | {
|
---|
18 | my($class, $scheme, $ua) = @_;
|
---|
19 |
|
---|
20 | my $self = bless {
|
---|
21 | scheme => $scheme,
|
---|
22 | ua => $ua,
|
---|
23 |
|
---|
24 | # historical/redundant
|
---|
25 | max_size => $ua->{max_size},
|
---|
26 | }, $class;
|
---|
27 |
|
---|
28 | $self;
|
---|
29 | }
|
---|
30 |
|
---|
31 |
|
---|
32 | sub create
|
---|
33 | {
|
---|
34 | my($scheme, $ua) = @_;
|
---|
35 | my $impclass = LWP::Protocol::implementor($scheme) or
|
---|
36 | Carp::croak("Protocol scheme '$scheme' is not supported");
|
---|
37 |
|
---|
38 | # hand-off to scheme specific implementation sub-class
|
---|
39 | my $protocol = $impclass->new($scheme, $ua);
|
---|
40 |
|
---|
41 | return $protocol;
|
---|
42 | }
|
---|
43 |
|
---|
44 |
|
---|
45 | sub implementor
|
---|
46 | {
|
---|
47 | my($scheme, $impclass) = @_;
|
---|
48 |
|
---|
49 | if ($impclass) {
|
---|
50 | $ImplementedBy{$scheme} = $impclass;
|
---|
51 | }
|
---|
52 | my $ic = $ImplementedBy{$scheme};
|
---|
53 | return $ic if $ic;
|
---|
54 |
|
---|
55 | return '' unless $scheme =~ /^([.+\-\w]+)$/; # check valid URL schemes
|
---|
56 | $scheme = $1; # untaint
|
---|
57 | $scheme =~ s/[.+\-]/_/g; # make it a legal module name
|
---|
58 |
|
---|
59 | # scheme not yet known, look for a 'use'd implementation
|
---|
60 | $ic = "LWP::Protocol::$scheme"; # default location
|
---|
61 | $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
|
---|
62 | no strict 'refs';
|
---|
63 | # check we actually have one for the scheme:
|
---|
64 | unless (@{"${ic}::ISA"}) {
|
---|
65 | # try to autoload it
|
---|
66 | eval "require $ic";
|
---|
67 | if ($@) {
|
---|
68 | if ($@ =~ /Can't locate/) { #' #emacs get confused by '
|
---|
69 | $ic = '';
|
---|
70 | }
|
---|
71 | else {
|
---|
72 | die "$@\n";
|
---|
73 | }
|
---|
74 | }
|
---|
75 | }
|
---|
76 | $ImplementedBy{$scheme} = $ic if $ic;
|
---|
77 | $ic;
|
---|
78 | }
|
---|
79 |
|
---|
80 |
|
---|
81 | sub request
|
---|
82 | {
|
---|
83 | my($self, $request, $proxy, $arg, $size, $timeout) = @_;
|
---|
84 | Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
|
---|
85 | }
|
---|
86 |
|
---|
87 |
|
---|
88 | # legacy
|
---|
89 | sub timeout { shift->_elem('timeout', @_); }
|
---|
90 | sub max_size { shift->_elem('max_size', @_); }
|
---|
91 |
|
---|
92 |
|
---|
93 | sub collect
|
---|
94 | {
|
---|
95 | my ($self, $arg, $response, $collector) = @_;
|
---|
96 | my $content;
|
---|
97 | my($ua, $max_size) = @{$self}{qw(ua max_size)};
|
---|
98 |
|
---|
99 | eval {
|
---|
100 | local $\; # protect the print below from surprises
|
---|
101 | if (!defined($arg) || !$response->is_success) {
|
---|
102 | $response->{default_add_content} = 1;
|
---|
103 | }
|
---|
104 | elsif (!ref($arg) && length($arg)) {
|
---|
105 | open(my $fh, ">", $arg) or die "Can't write to '$arg': $!";
|
---|
106 | binmode($fh);
|
---|
107 | push(@{$response->{handlers}{response_data}}, {
|
---|
108 | callback => sub {
|
---|
109 | print $fh $_[3] or die "Can't write to '$arg': $!";
|
---|
110 | 1;
|
---|
111 | },
|
---|
112 | });
|
---|
113 | push(@{$response->{handlers}{response_done}}, {
|
---|
114 | callback => sub {
|
---|
115 | close($fh) or die "Can't write to '$arg': $!";
|
---|
116 | undef($fh);
|
---|
117 | },
|
---|
118 | });
|
---|
119 | }
|
---|
120 | elsif (ref($arg) eq 'CODE') {
|
---|
121 | push(@{$response->{handlers}{response_data}}, {
|
---|
122 | callback => sub {
|
---|
123 | &$arg($_[3], $_[0], $self);
|
---|
124 | 1;
|
---|
125 | },
|
---|
126 | });
|
---|
127 | }
|
---|
128 | else {
|
---|
129 | die "Unexpected collect argument '$arg'";
|
---|
130 | }
|
---|
131 |
|
---|
132 | $ua->run_handlers("response_header", $response);
|
---|
133 |
|
---|
134 | if (delete $response->{default_add_content}) {
|
---|
135 | push(@{$response->{handlers}{response_data}}, {
|
---|
136 | callback => sub {
|
---|
137 | $_[0]->add_content($_[3]);
|
---|
138 | 1;
|
---|
139 | },
|
---|
140 | });
|
---|
141 | }
|
---|
142 |
|
---|
143 |
|
---|
144 | my $content_size = 0;
|
---|
145 | my $length = $response->content_length;
|
---|
146 | my %skip_h;
|
---|
147 |
|
---|
148 | while ($content = &$collector, length $$content) {
|
---|
149 | for my $h ($ua->handlers("response_data", $response)) {
|
---|
150 | next if $skip_h{$h};
|
---|
151 | unless ($h->{callback}->($response, $ua, $h, $$content)) {
|
---|
152 | # XXX remove from $response->{handlers}{response_data} if present
|
---|
153 | $skip_h{$h}++;
|
---|
154 | }
|
---|
155 | }
|
---|
156 | $content_size += length($$content);
|
---|
157 | $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
|
---|
158 | if (defined($max_size) && $content_size > $max_size) {
|
---|
159 | $response->push_header("Client-Aborted", "max_size");
|
---|
160 | last;
|
---|
161 | }
|
---|
162 | }
|
---|
163 | };
|
---|
164 | my $err = $@;
|
---|
165 | delete $response->{handlers}{response_data};
|
---|
166 | delete $response->{handlers} unless %{$response->{handlers}};
|
---|
167 | if ($err) {
|
---|
168 | chomp($err);
|
---|
169 | $response->push_header('X-Died' => $err);
|
---|
170 | $response->push_header("Client-Aborted", "die");
|
---|
171 | return $response;
|
---|
172 | }
|
---|
173 |
|
---|
174 | return $response;
|
---|
175 | }
|
---|
176 |
|
---|
177 |
|
---|
178 | sub collect_once
|
---|
179 | {
|
---|
180 | my($self, $arg, $response) = @_;
|
---|
181 | my $content = \ $_[3];
|
---|
182 | my $first = 1;
|
---|
183 | $self->collect($arg, $response, sub {
|
---|
184 | return $content if $first--;
|
---|
185 | return \ "";
|
---|
186 | });
|
---|
187 | }
|
---|
188 |
|
---|
189 | 1;
|
---|
190 |
|
---|
191 |
|
---|
192 | __END__
|
---|
193 |
|
---|
194 | =head1 NAME
|
---|
195 |
|
---|
196 | LWP::Protocol - Base class for LWP protocols
|
---|
197 |
|
---|
198 | =head1 SYNOPSIS
|
---|
199 |
|
---|
200 | package LWP::Protocol::foo;
|
---|
201 | require LWP::Protocol;
|
---|
202 | @ISA=qw(LWP::Protocol);
|
---|
203 |
|
---|
204 | =head1 DESCRIPTION
|
---|
205 |
|
---|
206 | This class is used a the base class for all protocol implementations
|
---|
207 | supported by the LWP library.
|
---|
208 |
|
---|
209 | When creating an instance of this class using
|
---|
210 | C<LWP::Protocol::create($url)>, and you get an initialised subclass
|
---|
211 | appropriate for that access method. In other words, the
|
---|
212 | LWP::Protocol::create() function calls the constructor for one of its
|
---|
213 | subclasses.
|
---|
214 |
|
---|
215 | All derived LWP::Protocol classes need to override the request()
|
---|
216 | method which is used to service a request. The overridden method can
|
---|
217 | make use of the collect() function to collect together chunks of data
|
---|
218 | as it is received.
|
---|
219 |
|
---|
220 | The following methods and functions are provided:
|
---|
221 |
|
---|
222 | =over 4
|
---|
223 |
|
---|
224 | =item $prot = LWP::Protocol->new()
|
---|
225 |
|
---|
226 | The LWP::Protocol constructor is inherited by subclasses. As this is a
|
---|
227 | virtual base class this method should B<not> be called directly.
|
---|
228 |
|
---|
229 | =item $prot = LWP::Protocol::create($scheme)
|
---|
230 |
|
---|
231 | Create an object of the class implementing the protocol to handle the
|
---|
232 | given scheme. This is a function, not a method. It is more an object
|
---|
233 | factory than a constructor. This is the function user agents should
|
---|
234 | use to access protocols.
|
---|
235 |
|
---|
236 | =item $class = LWP::Protocol::implementor($scheme, [$class])
|
---|
237 |
|
---|
238 | Get and/or set implementor class for a scheme. Returns '' if the
|
---|
239 | specified scheme is not supported.
|
---|
240 |
|
---|
241 | =item $prot->request(...)
|
---|
242 |
|
---|
243 | $response = $protocol->request($request, $proxy, undef);
|
---|
244 | $response = $protocol->request($request, $proxy, '/tmp/sss');
|
---|
245 | $response = $protocol->request($request, $proxy, \&callback, 1024);
|
---|
246 |
|
---|
247 | Dispatches a request over the protocol, and returns a response
|
---|
248 | object. This method needs to be overridden in subclasses. Refer to
|
---|
249 | L<LWP::UserAgent> for description of the arguments.
|
---|
250 |
|
---|
251 | =item $prot->collect($arg, $response, $collector)
|
---|
252 |
|
---|
253 | Called to collect the content of a request, and process it
|
---|
254 | appropriately into a scalar, file, or by calling a callback. If $arg
|
---|
255 | is undefined, then the content is stored within the $response. If
|
---|
256 | $arg is a simple scalar, then $arg is interpreted as a file name and
|
---|
257 | the content is written to this file. If $arg is a reference to a
|
---|
258 | routine, then content is passed to this routine.
|
---|
259 |
|
---|
260 | The $collector is a routine that will be called and which is
|
---|
261 | responsible for returning pieces (as ref to scalar) of the content to
|
---|
262 | process. The $collector signals EOF by returning a reference to an
|
---|
263 | empty sting.
|
---|
264 |
|
---|
265 | The return value from collect() is the $response object reference.
|
---|
266 |
|
---|
267 | B<Note:> We will only use the callback or file argument if
|
---|
268 | $response->is_success(). This avoids sending content data for
|
---|
269 | redirects and authentication responses to the callback which would be
|
---|
270 | confusing.
|
---|
271 |
|
---|
272 | =item $prot->collect_once($arg, $response, $content)
|
---|
273 |
|
---|
274 | Can be called when the whole response content is available as
|
---|
275 | $content. This will invoke collect() with a collector callback that
|
---|
276 | returns a reference to $content the first time and an empty string the
|
---|
277 | next.
|
---|
278 |
|
---|
279 | =back
|
---|
280 |
|
---|
281 | =head1 SEE ALSO
|
---|
282 |
|
---|
283 | Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
|
---|
284 | for examples of usage.
|
---|
285 |
|
---|
286 | =head1 COPYRIGHT
|
---|
287 |
|
---|
288 | Copyright 1995-2001 Gisle Aas.
|
---|
289 |
|
---|
290 | This library is free software; you can redistribute it and/or
|
---|
291 | modify it under the same terms as Perl itself.
|
---|