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