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