summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm72
1 files changed, 72 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm b/Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm
new file mode 100644
index 00000000000..66d8f213b98
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/LWP/Protocol/cpan.pm
@@ -0,0 +1,72 @@
+package LWP::Protocol::cpan;
+
+use strict;
+use vars qw(@ISA);
+
+require LWP::Protocol;
+@ISA = qw(LWP::Protocol);
+
+require URI;
+require HTTP::Status;
+require HTTP::Response;
+
+our $CPAN;
+
+unless ($CPAN) {
+ # Try to find local CPAN mirror via $CPAN::Config
+ eval {
+ require CPAN::Config;
+ if($CPAN::Config) {
+ my $urls = $CPAN::Config->{urllist};
+ if (ref($urls) eq "ARRAY") {
+ my $file;
+ for (@$urls) {
+ if (/^file:/) {
+ $file = $_;
+ last;
+ }
+ }
+
+ if ($file) {
+ $CPAN = $file;
+ }
+ else {
+ $CPAN = $urls->[0];
+ }
+ }
+ }
+ };
+
+ $CPAN ||= "http://cpan.org/"; # last resort
+}
+
+# ensure that we don't chop of last part
+$CPAN .= "/" unless $CPAN =~ m,/$,;
+
+
+sub request {
+ my($self, $request, $proxy, $arg, $size) = @_;
+ # check proxy
+ if (defined $proxy)
+ {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'You can not proxy with cpan');
+ }
+
+ # check method
+ my $method = $request->method;
+ unless ($method eq 'GET' || $method eq 'HEAD') {
+ return HTTP::Response->new(&HTTP::Status::RC_BAD_REQUEST,
+ 'Library does not allow method ' .
+ "$method for 'cpan:' URLs");
+ }
+
+ my $path = $request->uri->path;
+ $path =~ s,^/,,;
+
+ my $response = HTTP::Response->new(&HTTP::Status::RC_FOUND);
+ $response->header("Location" => URI->new_abs($path, $CPAN));
+ $response;
+}
+
+1;