git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol.pm

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