local-lib5/lib/perl5/LWP/Protocol.pm

   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.