git.maemo.org Git - pkg-perl/blob - deb-src/libwww-perl/libwww-perl-5.813/lib/LWP/Protocol/cpan.pm

   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;