home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _a30595cfd917bc0e802ef3e81db66078 < prev    next >
Text File  |  2004-06-01  |  2KB  |  77 lines
  1. package LWP::Protocol::GHTTP;
  2.  
  3. # $Id: GHTTP.pm,v 1.3 2003/10/14 12:01:27 gisle Exp $ 
  4.  
  5. #
  6. # You can tell LWP to use this module for 'http' requests by running
  7. # code like this before you make requests:
  8. #
  9. #    require LWP::Protocol::GHTTP;
  10. #    LWP::Protocol::implementor('http', 'LWP::Protocol::GHTTP');
  11. #
  12.  
  13. use strict;
  14. use vars qw(@ISA);
  15.  
  16. require LWP::Protocol;
  17. @ISA=qw(LWP::Protocol);
  18.  
  19. require HTTP::Response;
  20. require HTTP::Status;
  21.  
  22. use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST);
  23.  
  24. my %METHOD =
  25. (
  26.  GET  => METHOD_GET,
  27.  HEAD => METHOD_HEAD,
  28.  POST => METHOD_POST,
  29. );
  30.  
  31. sub request
  32. {
  33.     my($self, $request, $proxy, $arg, $size, $timeout) = @_;
  34.  
  35.     my $method = $request->method;
  36.     unless (exists $METHOD{$method}) {
  37.     return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
  38.                    "Bad method '$method'");
  39.     }
  40.  
  41.     my $r = HTTP::GHTTP->new($request->uri);
  42.  
  43.     # XXX what headers for repeated headers here?
  44.     $request->headers->scan(sub { $r->set_header(@_)});
  45.  
  46.     $r->set_type($METHOD{$method});
  47.  
  48.     # XXX should also deal with subroutine content.
  49.     my $cref = $request->content_ref;
  50.     $r->set_body($$cref) if length($$cref);
  51.  
  52.     # XXX is this right
  53.     $r->set_proxy($proxy->as_string) if $proxy;
  54.  
  55.     $r->process_request;
  56.  
  57.     my $response = HTTP::Response->new($r->get_status);
  58.  
  59.     # XXX How can get the headers out of $r??  This way is too stupid.
  60.     my @headers;
  61.     eval {
  62.     # Wrapped in eval because this method is not always available
  63.     @headers = $r->get_headers;
  64.     };
  65.     @headers = qw(Date Connection Server Content-type
  66.                   Accept-Ranges Server
  67.                   Content-Length Last-Modified ETag) if $@;
  68.     for (@headers) {
  69.     my $v = $r->get_header($_);
  70.     $response->header($_ => $v) if defined $v;
  71.     }
  72.  
  73.     return $self->collect_once($arg, $response, $r->get_body);
  74. }
  75.  
  76. 1;
  77.