Commit | Line | Data |
3fea05b9 |
1 | package LWP::Protocol::cpan; |
2 | |
3 | use strict; |
4 | use vars qw(@ISA); |
5 | |
6 | require LWP::Protocol; |
7 | @ISA = qw(LWP::Protocol); |
8 | |
9 | require URI; |
10 | require HTTP::Status; |
11 | require HTTP::Response; |
12 | |
13 | our $CPAN; |
14 | |
15 | unless ($CPAN) { |
16 | # Try to find local CPAN mirror via $CPAN::Config |
17 | eval { |
18 | require CPAN::Config; |
19 | if($CPAN::Config) { |
20 | my $urls = $CPAN::Config->{urllist}; |
21 | if (ref($urls) eq "ARRAY") { |
22 | my $file; |
23 | for (@$urls) { |
24 | if (/^file:/) { |
25 | $file = $_; |
26 | last; |
27 | } |
28 | } |
29 | |
30 | if ($file) { |
31 | $CPAN = $file; |
32 | } |
33 | else { |
34 | $CPAN = $urls->[0]; |
35 | } |
36 | } |
37 | } |
38 | }; |
39 | |
40 | $CPAN ||= "http://cpan.org/"; # last resort |
41 | } |
42 | |
43 | # ensure that we don't chop of last part |
44 | $CPAN .= "/" unless $CPAN =~ m,/$,; |
45 | |
46 | |
47 | sub request { |
48 | my($self, $request, $proxy, $arg, $size) = @_; |
49 | # check proxy |
50 | if (defined $proxy) |
51 | { |
52 | return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, |
53 | 'You can not proxy with cpan'); |
54 | } |
55 | |
56 | # check method |
57 | my $method = $request->method; |
58 | unless ($method eq 'GET' || $method eq 'HEAD') { |
59 | return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST, |
60 | 'Library does not allow method ' . |
61 | "$method for 'cpan:' URLs"); |
62 | } |
63 | |
64 | my $path = $request->uri->path; |
65 | $path =~ s,^/,,; |
66 | |
67 | my $response = HTTP::Response->new(&HTTP::Status::RC_FOUND); |
68 | $response->header("Location" => URI->new_abs($path, $CPAN)); |
69 | $response; |
70 | } |
71 | |
72 | 1; |