home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Protocol.pm < prev    next >
Encoding:
Perl POD Document  |  2008-11-05  |  7.6 KB  |  289 lines
  1. package LWP::Protocol;
  2.  
  3. require LWP::MemberMixin;
  4. @ISA = qw(LWP::MemberMixin);
  5. $VERSION = "5.820";
  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.         if (!defined($arg) || !$response->is_success) {
  101.             $response->{default_add_content} = 1;
  102.         }
  103.         elsif (!ref($arg) && length($arg)) {
  104.             open(my $fh, ">", $arg) || die "Can't write to '$arg': $!";
  105.         binmode($fh);
  106.             push(@{$response->{handlers}{response_data}}, {
  107.                 callback => sub {
  108.                     print $fh $_[3] || die "Can't write to '$arg': $!";
  109.                     1;
  110.                 },
  111.             });
  112.             push(@{$response->{handlers}{response_done}}, {
  113.                 callback => sub {
  114.             close($fh) || die "Can't write to '$arg': $!";
  115.             undef($fh);
  116.         },
  117.         });
  118.         }
  119.         elsif (ref($arg) eq 'CODE') {
  120.             push(@{$response->{handlers}{response_data}}, {
  121.                 callback => sub {
  122.             &$arg($_[3], $_[0], $self);
  123.             1;
  124.                 },
  125.             });
  126.         }
  127.         else {
  128.             die "Unexpected collect argument '$arg'";
  129.         }
  130.  
  131.         $ua->run_handlers("response_header", $response);
  132.  
  133.         if (delete $response->{default_add_content}) {
  134.             push(@{$response->{handlers}{response_data}}, {
  135.         callback => sub {
  136.             $_[0]->add_content($_[3]);
  137.             1;
  138.         },
  139.         });
  140.         }
  141.  
  142.  
  143.         my $content_size = 0;
  144.         my $length = $response->content_length;
  145.         my %skip_h;
  146.  
  147.         while ($content = &$collector, length $$content) {
  148.             for my $h ($ua->handlers("response_data", $response)) {
  149.                 next if $skip_h{$h};
  150.                 unless ($h->{callback}->($response, $ua, $h, $$content)) {
  151.                     # XXX remove from $response->{handlers}{response_data} if present
  152.                     $skip_h{$h}++;
  153.                 }
  154.             }
  155.             $content_size += length($$content);
  156.             $ua->progress(($length ? ($content_size / $length) : "tick"), $response);
  157.             if (defined($max_size) && $content_size > $max_size) {
  158.                 LWP::Debug::debug("Aborting because size limit exceeded");
  159.                 $response->push_header("Client-Aborted", "max_size");
  160.                 last;
  161.             }
  162.         }
  163.     };
  164.     if ($@) {
  165.         chomp($@);
  166.         $response->push_header('X-Died' => $@);
  167.         $response->push_header("Client-Aborted", "die");
  168.         return $response;
  169.     }
  170.  
  171.     return $response;
  172. }
  173.  
  174.  
  175. sub collect_once
  176. {
  177.     my($self, $arg, $response) = @_;
  178.     my $content = \ $_[3];
  179.     my $first = 1;
  180.     $self->collect($arg, $response, sub {
  181.     return $content if $first--;
  182.     return \ "";
  183.     });
  184. }
  185.  
  186. 1;
  187.  
  188.  
  189. __END__
  190.  
  191. =head1 NAME
  192.  
  193. LWP::Protocol - Base class for LWP protocols
  194.  
  195. =head1 SYNOPSIS
  196.  
  197.  package LWP::Protocol::foo;
  198.  require LWP::Protocol;
  199.  @ISA=qw(LWP::Protocol);
  200.  
  201. =head1 DESCRIPTION
  202.  
  203. This class is used a the base class for all protocol implementations
  204. supported by the LWP library.
  205.  
  206. When creating an instance of this class using
  207. C<LWP::Protocol::create($url)>, and you get an initialised subclass
  208. appropriate for that access method. In other words, the
  209. LWP::Protocol::create() function calls the constructor for one of its
  210. subclasses.
  211.  
  212. All derived LWP::Protocol classes need to override the request()
  213. method which is used to service a request. The overridden method can
  214. make use of the collect() function to collect together chunks of data
  215. as it is received.
  216.  
  217. The following methods and functions are provided:
  218.  
  219. =over 4
  220.  
  221. =item $prot = LWP::Protocol->new()
  222.  
  223. The LWP::Protocol constructor is inherited by subclasses. As this is a
  224. virtual base class this method should B<not> be called directly.
  225.  
  226. =item $prot = LWP::Protocol::create($scheme)
  227.  
  228. Create an object of the class implementing the protocol to handle the
  229. given scheme. This is a function, not a method. It is more an object
  230. factory than a constructor. This is the function user agents should
  231. use to access protocols.
  232.  
  233. =item $class = LWP::Protocol::implementor($scheme, [$class])
  234.  
  235. Get and/or set implementor class for a scheme.  Returns '' if the
  236. specified scheme is not supported.
  237.  
  238. =item $prot->request(...)
  239.  
  240.  $response = $protocol->request($request, $proxy, undef);
  241.  $response = $protocol->request($request, $proxy, '/tmp/sss');
  242.  $response = $protocol->request($request, $proxy, \&callback, 1024);
  243.  
  244. Dispatches a request over the protocol, and returns a response
  245. object. This method needs to be overridden in subclasses.  Refer to
  246. L<LWP::UserAgent> for description of the arguments.
  247.  
  248. =item $prot->collect($arg, $response, $collector)
  249.  
  250. Called to collect the content of a request, and process it
  251. appropriately into a scalar, file, or by calling a callback.  If $arg
  252. is undefined, then the content is stored within the $response.  If
  253. $arg is a simple scalar, then $arg is interpreted as a file name and
  254. the content is written to this file.  If $arg is a reference to a
  255. routine, then content is passed to this routine.
  256.  
  257. The $collector is a routine that will be called and which is
  258. responsible for returning pieces (as ref to scalar) of the content to
  259. process.  The $collector signals EOF by returning a reference to an
  260. empty sting.
  261.  
  262. The return value from collect() is the $response object reference.
  263.  
  264. B<Note:> We will only use the callback or file argument if
  265. $response->is_success().  This avoids sending content data for
  266. redirects and authentication responses to the callback which would be
  267. confusing.
  268.  
  269. =item $prot->collect_once($arg, $response, $content)
  270.  
  271. Can be called when the whole response content is available as
  272. $content.  This will invoke collect() with a collector callback that
  273. returns a reference to $content the first time and an empty string the
  274. next.
  275.  
  276. =back
  277.  
  278. =head1 SEE ALSO
  279.  
  280. Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
  281. for examples of usage.
  282.  
  283. =head1 COPYRIGHT
  284.  
  285. Copyright 1995-2001 Gisle Aas.
  286.  
  287. This library is free software; you can redistribute it and/or
  288. modify it under the same terms as Perl itself.
  289.