Commit | Line | Data |
3fea05b9 |
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; |