Last change
on this file since 27174 was 27174, checked in by davidb, 11 years ago |
Perl modules from CPAN that are used in supporting activate.pl, but not part of the Perl core. Only PMs included.
|
File size:
1.3 KB
|
Line | |
---|
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;
|
---|
Note:
See
TracBrowser
for help on using the repository browser.