Last change
on this file since 27183 was 27183, checked in by davidb, 11 years ago |
Changing to using installed version of LWP that comes from libwww-perl, which is more self-contained than v6.x
|
File size:
1.3 KB
|
Rev | Line | |
---|
[27183] | 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.