home *** CD-ROM | disk | FTP | other *** search
/ ftp.f-secure.com / 2014.06.ftp.f-secure.com.tar / ftp.f-secure.com / support / hotfix / fsis / IS-SpamControl.fsfix / iufssc / lib / LWP / Protocol.pm < prev    next >
Text File  |  2006-11-29  |  8KB  |  290 lines
  1. package LWP::Protocol;
  2.  
  3. # $Id: Protocol.pm 2397 2005-12-23 13:06:15Z kankri $
  4.  
  5. require LWP::MemberMixin;
  6. @ISA = qw(LWP::MemberMixin);
  7. $VERSION = sprintf("%d.%02d", q$Revision: 2397 $ =~ /(\d+)\.(\d+)/);
  8.  
  9. use strict;
  10. use Carp ();
  11. use HTTP::Status ();
  12. use HTTP::Response;
  13.  
  14. my %ImplementedBy = (); # scheme => classname
  15.  
  16.  
  17.  
  18. sub new
  19. {
  20.     my($class, $scheme, $ua) = @_;
  21.  
  22.     my $self = bless {
  23.     scheme => $scheme,
  24.     ua => $ua,
  25.  
  26.     # historical/redundant
  27.         parse_head => $ua->{parse_head},
  28.         max_size => $ua->{max_size},
  29.     }, $class;
  30.  
  31.     $self;
  32. }
  33.  
  34.  
  35. sub create
  36. {
  37.     my($scheme, $ua) = @_;
  38.     my $impclass = LWP::Protocol::implementor($scheme) or
  39.     Carp::croak("Protocol scheme '$scheme' is not supported");
  40.  
  41.     # hand-off to scheme specific implementation sub-class
  42.     my $protocol = $impclass->new($scheme, $ua);
  43.  
  44.     return $protocol;
  45. }
  46.  
  47.  
  48. sub implementor
  49. {
  50.     my($scheme, $impclass) = @_;
  51.  
  52.     if ($impclass) {
  53.     $ImplementedBy{$scheme} = $impclass;
  54.     }
  55.     my $ic = $ImplementedBy{$scheme};
  56.     return $ic if $ic;
  57.  
  58.     return '' unless $scheme =~ /^([.+\-\w]+)$/;  # check valid URL schemes
  59.     $scheme = $1; # untaint
  60.     $scheme =~ s/[.+\-]/_/g;  # make it a legal module name
  61.  
  62.     # scheme not yet known, look for a 'use'd implementation
  63.     $ic = "LWP::Protocol::$scheme";  # default location
  64.     $ic = "LWP::Protocol::nntp" if $scheme eq 'news'; #XXX ugly hack
  65.     no strict 'refs';
  66.     # check we actually have one for the scheme:
  67.     unless (@{"${ic}::ISA"}) {
  68.     # try to autoload it
  69.     eval "require $ic";
  70.     if ($@) {
  71.         if ($@ =~ /Can't locate/) { #' #emacs get confused by '
  72.         $ic = '';
  73.         }
  74.         else {
  75.         die "$@\n";
  76.         }
  77.     }
  78.     }
  79.     $ImplementedBy{$scheme} = $ic if $ic;
  80.     $ic;
  81. }
  82.  
  83.  
  84. sub request
  85. {
  86.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  87.     Carp::croak('LWP::Protocol::request() needs to be overridden in subclasses');
  88. }
  89.  
  90.  
  91. # legacy
  92. sub timeout    { shift->_elem('timeout',    @_); }
  93. sub parse_head { shift->_elem('parse_head', @_); }
  94. sub max_size   { shift->_elem('max_size',   @_); }
  95.  
  96.  
  97. sub collect
  98. {
  99.     my ($self, $arg, $response, $collector) = @_;
  100.     my $content;
  101.     my($parse_head, $max_size) = @{$self}{qw(parse_head max_size)};
  102.  
  103.     my $parser;
  104.     if ($parse_head && $response->content_type eq 'text/html') {
  105.     require HTML::HeadParser;
  106.     $parser = HTML::HeadParser->new($response->{'_headers'});
  107.     }
  108.     my $content_size = 0;
  109.  
  110.     if (!defined($arg) || !$response->is_success) {
  111.     # scalar
  112.     while ($content = &$collector, length $$content) {
  113.         if ($parser) {
  114.         $parser->parse($$content) or undef($parser);
  115.         }
  116.         LWP::Debug::debug("read " . length($$content) . " bytes");
  117.         $response->add_content($$content);
  118.         $content_size += length($$content);
  119.         if (defined($max_size) && $content_size > $max_size) {
  120.         LWP::Debug::debug("Aborting because size limit exceeded");
  121.         $response->push_header("Client-Aborted", "max_size");
  122.         #my $tot = $response->header("Content-Length") || 0;
  123.         #$response->header("X-Content-Range", "bytes 0-$content_size/$tot");
  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.         if (defined($max_size) && $content_size > $max_size) {
  143.         LWP::Debug::debug("Aborting because size limit exceeded");
  144.         $response->push_header("Client-Aborted", "max_size");
  145.         #my $tot = $response->header("Content-Length") || 0;
  146.         #$response->header("X-Content-Range", "bytes 0-$content_size/$tot");
  147.         last;
  148.         }
  149.     }
  150.     close(OUT) or die "Can't write to '$arg': $!";
  151.     }
  152.     elsif (ref($arg) eq 'CODE') {
  153.     # read into callback
  154.     while ($content = &$collector, length $$content) {
  155.         if ($parser) {
  156.         $parser->parse($$content) or undef($parser);
  157.         }
  158.         LWP::Debug::debug("read " . length($$content) . " bytes");
  159.             eval {
  160.         &$arg($$content, $response, $self);
  161.         };
  162.         if ($@) {
  163.             chomp($@);
  164.         $response->push_header('X-Died' => $@);
  165.         $response->push_header("Client-Aborted", "die");
  166.         last;
  167.         }
  168.     }
  169.     }
  170.     else {
  171.     return HTTP::Response->new(&HTTP::Status::RC_INTERNAL_SERVER_ERROR,
  172.                   "Unexpected collect argument  '$arg'");
  173.     }
  174.     $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. =head1 SEE ALSO
  280.  
  281. Inspect the F<LWP/Protocol/file.pm> and F<LWP/Protocol/http.pm> files
  282. for examples of usage.
  283.  
  284. =head1 COPYRIGHT
  285.  
  286. Copyright 1995-2001 Gisle Aas.
  287.  
  288. This library is free software; you can redistribute it and/or
  289. modify it under the same terms as Perl itself.
  290.