/extras/perl/site_perl/LWP/Protocol/GHTTP.pm

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