home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _38ae4be554d52ece502fb9d3fb7b4a63 < prev    next >
Encoding:
Text File  |  2004-06-01  |  1.4 KB  |  73 lines
  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;
  73.