1 | package 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 |
|
---|
10 | use strict;
|
---|
11 | use vars qw(@ISA);
|
---|
12 |
|
---|
13 | require LWP::Protocol;
|
---|
14 | @ISA=qw(LWP::Protocol);
|
---|
15 |
|
---|
16 | require HTTP::Response;
|
---|
17 | require HTTP::Status;
|
---|
18 |
|
---|
19 | use HTTP::GHTTP qw(METHOD_GET METHOD_HEAD METHOD_POST);
|
---|
20 |
|
---|
21 | my %METHOD =
|
---|
22 | (
|
---|
23 | GET => METHOD_GET,
|
---|
24 | HEAD => METHOD_HEAD,
|
---|
25 | POST => METHOD_POST,
|
---|
26 | );
|
---|
27 |
|
---|
28 | sub 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 |
|
---|
73 | 1;
|
---|