Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Loading…

Change the handling of URI scheme backends #119

Open
wants to merge 9 commits into from

4 participants

@maxatome

It probes the right backend only when a specific URI scheme is required.
Now cpanm can handle scp:// and sftp:// URI schemes using scp, sftp or curl.
Add options --scp and --sftp (same meaning as --wget and co).
Can load dynamic URI scheme backend from the namespace App::cpanminus::backend:: (perhaps another namespace is better appropriate?)

maxatome added some commits
@maxatome maxatome Quick hack to permit the use of scp:// URLs by using the "scp"
command, allowing to join a DPAN over SSH :

  cpanm -i --mirror scp://user@host:. PrivateModule
d42469b
@maxatome maxatome Change the handling of URI scheme backends.
It probes the right backend only when a specific URI scheme is
required.
Now cpanm can handle scp:// and sftp:// URI schemes using scp, sftp or
curl.
Add options --scp and --sftp (same meaning as --wget and co).
Can load dynamic URI scheme backend in the namespace
App::cpanminus::backend::.
88e9dfa
@maxatome maxatome file:// URI scheme was not correctly handled. Corrected. 3bece3b
@markstos

Nice idea. I hope some version of this gets accepted.

@miyagawa
Owner

The patch isn't so bad but it adds so much complexity to the code and it goes against the cpan"minus".

@maxatome

I don't think it add complexity. The diff seems large because of the move of the http/ftp handling code block, but now the code allows to use protocols other than ftp/http. In some cases, deployment of DarkPAN modules, it would be a must have.
But you are the master :)

maxatome added some commits
@maxatome maxatome untabify.
use get_scheme_backend() in resolve_name to avoid a static list of URI
schemes.
Factorize curl options.
c9a771d
@maxatome maxatome Change the API for backend modules in App::cpanminus::backend::*
namespaces. They should implement get and mirror functions instead of
returning a hash ref. Thanks to Paweł Murias for the tip.
URL was not correcly detected. Corrected.
e04b5c8
@maxatome maxatome When an interactive question occurs and prompt is disabled or STDIN is
not a tty, add the default answer to the logs.
4938966
@maxatome maxatome Merge branch 'master' of git://github.com/maxatome/cpanminus fe8610e
@maxatome maxatome Merge remote-tracking branch 'upstream/master' 65da339
@maxatome maxatome Merge remote-tracking branch 'upstream/master' 31364c0
@dolmen

URI schemes are already pluggable through LWP.

To access a repository through SSH (like with the proposed scp:// scheme), everything already exists on the CPAN: just install LWP::Protocol::sftp and use an sftp:// URI for your mirror.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Commits on Sep 29, 2011
  1. @maxatome

    Quick hack to permit the use of scp:// URLs by using the "scp"

    maxatome authored
    command, allowing to join a DPAN over SSH :
    
      cpanm -i --mirror scp://user@host:. PrivateModule
Commits on Sep 30, 2011
  1. @maxatome

    Change the handling of URI scheme backends.

    maxatome authored
    It probes the right backend only when a specific URI scheme is
    required.
    Now cpanm can handle scp:// and sftp:// URI schemes using scp, sftp or
    curl.
    Add options --scp and --sftp (same meaning as --wget and co).
    Can load dynamic URI scheme backend in the namespace
    App::cpanminus::backend::.
  2. @maxatome
Commits on Oct 1, 2011
  1. @maxatome

    untabify.

    maxatome authored
    use get_scheme_backend() in resolve_name to avoid a static list of URI
    schemes.
    Factorize curl options.
Commits on Oct 2, 2011
  1. @maxatome

    Change the API for backend modules in App::cpanminus::backend::*

    maxatome authored
    namespaces. They should implement get and mirror functions instead of
    returning a hash ref. Thanks to Paweł Murias for the tip.
    URL was not correcly detected. Corrected.
Commits on Oct 13, 2011
  1. @maxatome

    When an interactive question occurs and prompt is disabled or STDIN is

    maxatome authored
    not a tty, add the default answer to the logs.
  2. @maxatome
  3. @maxatome
Commits on Oct 14, 2011
  1. @maxatome
This page is out of date. Refresh to see the latest.
Showing with 224 additions and 80 deletions.
  1. +205 −78 lib/App/cpanminus/script.pm
  2. +19 −2 script/cpanm.PL
View
283 lib/App/cpanminus/script.pm
@@ -1,3 +1,4 @@
+
package App::cpanminus::script;
use strict;
use Config;
@@ -47,6 +48,8 @@ sub new {
try_lwp => 1,
try_wget => 1,
try_curl => 1,
+ try_scp => 1,
+ try_sftp => 1,
uninstall_shadows => ($] < 5.012),
skip_installed => 1,
skip_satisfied => 0,
@@ -109,6 +112,8 @@ sub parse_options {
'lwp!' => \$self->{try_lwp},
'wget!' => \$self->{try_wget},
'curl!' => \$self->{try_curl},
+ 'scp!' => \$self->{try_scp},
+ 'sftp!' => \$self->{try_sftp},
'auto-cleanup=s' => \$self->{auto_cleanup},
'man-pages!' => \$self->{pod2man},
'scandeps' => \$self->{scandeps},
@@ -337,8 +342,7 @@ sub search_module {
$self->diag_fail("Finding $module on cpanmetadb failed.");
$self->chat("Searching $module on search.cpan.org ...\n");
- my $uri = "http://search.cpan.org/perldoc?$module";
- my $html = $self->get($uri);
+ my $html = $self->get("http://search.cpan.org/perldoc?$module");
$html =~ m!<a href="/CPAN/authors/id/(.*?\.(?:tar\.gz|tgz|tar\.bz2|zip))">!
and return $self->cpan_module($module, $1);
@@ -589,6 +593,7 @@ sub prompt {
$def = defined $def ? $def : "";
if (!$self->{prompt} || (!$isa_tty && eof STDIN)) {
+ $self->chat("$mess $dispdef$def\n");
return $def;
}
@@ -985,7 +990,7 @@ sub resolve_name {
my($self, $module, $version) = @_;
# URL
- if ($module =~ /^(ftp|https?|file):/) {
+ if ($self->get_scheme_backend($module, 1)) {
if ($module =~ m!authors/id/!) {
return $self->cpan_dist($module, $module);
} else {
@@ -1026,7 +1031,7 @@ sub resolve_name {
sub cpan_module {
my($self, $module, $dist, $version) = @_;
- my $dist = $self->cpan_dist($dist);
+ $dist = $self->cpan_dist($dist);
$dist->{module} = $module;
$dist->{module_version} = $version if $version && $version ne 'undef';
@@ -1694,8 +1699,202 @@ sub which {
return;
}
-sub get { $_[0]->{_backends}{get}->(@_) };
-sub mirror { $_[0]->{_backends}{mirror}->(@_) };
+# curl can be used for https?|ftp|scp|sftp
+sub _curl_backend {
+ my($self, $curl) = @_;
+ return {
+ get => sub {
+ my($self, $uri) = @_;
+ $self->safeexec( my $fh, $curl, '-L', ( $self->{verbose} ? () : '-s' ), $uri ) or die "curl $uri: $!";
+ local $/;
+ <$fh>;
+ },
+ mirror => sub {
+ my($self, $uri, $path) = @_;
+ $self->safeexec( my $fh, $curl, '-L', ( $self->{verbose} ? () : '-s' ), '-#', '-o', $path ) or die "curl $uri: $!";
+ local $/;
+ <$fh>;
+ },
+ };
+}
+
+sub get_scheme_backend {
+ my($self, $uri, $accept_only_uri) = @_;
+ my $scheme;
+ if ($uri =~ m,^([a-zA-Z][a-zA-Z0-9.+\-]*)://,) {
+ $scheme = $1;
+ } else {
+ return if $accept_only_uri;
+ $scheme = 'file';
+ }
+ unless (exists $self->{_backends}{"/$scheme"}) { # prefix with / to keep the name uniq
+ my $backend;
+ # Try to load the correct backend
+ if ($scheme eq 'file') {
+ $backend = {
+ get => sub {
+ my($self, $uri) = @_;
+ $uri =~ s,^file://,,;
+ $self->file_get($uri);
+ },
+ mirror => sub {
+ my($self, $uri, $path) = @_;
+ $uri =~ s,^file://,,;
+ $self->file_mirror($uri, $path);
+ },
+ };
+ }
+ elsif ($scheme =~ /^(?:https?|ftp)\z/) {
+ # use --no-lwp if they have a broken LWP, to upgrade LWP
+ if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) {
+ $self->chat("You have LWP $LWP::VERSION\n");
+ my $ua = sub {
+ LWP::UserAgent->new(
+ parse_head => 0,
+ env_proxy => 1,
+ agent => "cpanminus/$VERSION",
+ timeout => 30,
+ @_,
+ );
+ };
+ $backend = {
+ get => sub {
+ my $self = shift;
+ my $res = $ua->()->request(HTTP::Request->new(GET => $_[0]));
+ return unless $res->is_success;
+ return $res->decoded_content;
+ },
+ mirror => sub {
+ my $self = shift;
+ my $res = $ua->()->mirror(@_);
+ $res->code;
+ },
+ };
+ } elsif ($self->{try_wget} and my $wget = $self->which('wget')) {
+ $self->chat("You have $wget\n");
+ $backend = {
+ get => sub {
+ my($self, $uri) = @_;
+ $self->safeexec( my $fh, $wget, $uri, ( $self->{verbose} ? () : '-q' ), '-O', '-' ) or die "wget $uri: $!";
+ local $/;
+ <$fh>;
+ },
+ mirror => sub {
+ my($self, $uri, $path) = @_;
+ $self->safeexec( my $fh, $wget, '--retry-connrefused', $uri, ( $self->{verbose} ? () : '-q' ), '-O', $path ) or die "wget $uri: $!";
+ local $/;
+ <$fh>;
+ },
+ };
+ } elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
+ $self->chat("You have $curl\n");
+ $backend = $self->_curl_backend($curl);
+ } elsif (eval { require HTTP::Tiny }) {
+ $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");
+ $backend = {
+ get => sub {
+ my $self = shift;
+ my $res = HTTP::Tiny->new->get($_[0]);
+ return unless $res->{success};
+ return $res->{content};
+ },
+ mirror => sub {
+ my $self = shift;
+ my $res = HTTP::Tiny->new->mirror(@_);
+ return $res->{status};
+ },
+ };
+ }
+ } elsif ($scheme eq 'scp') {
+ if ($self->{try_scp} and my $scp = $self->which('scp')) {
+ $self->chat("You have $scp\n");
+ my($output_file, $is_tmp_file);
+ if (-c '/dev/fd/1') {
+ $output_file = '/dev/fd/1';
+ } else {
+ $is_tmp_file = 1;
+ $output_file = "$self->{base}/scp.tmp";
+ }
+ $backend = {
+ get => sub {
+ my($self, $uri) = @_;
+ $uri =~ s,^scp://,,;
+ $self->safeexec( my $fh, $scp, ( $self->{verbose} ? () : '-q' ), '-B', $uri, $output_file ) or die "scp $uri: $!";
+ if ($is_tmp_file) {
+ my $content = $self->file_get($output_file);
+ unlink $output_file;
+ return $content;
+ }
+ local $/;
+ join '', <$fh>;
+ },
+ mirror => sub {
+ my($self, $uri, $path) = @_;
+ $uri =~ s,^scp://,,;
+ $self->safeexec( my $fh, $scp, ( $self->{verbose} ? () : '-q' ), '-B', $uri, $path ) or die "scp $uri: $!";
+ local $/;
+ join '', <$fh>;
+ },
+ };
+ } elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
+ $self->chat("You have $curl\n");
+ $backend = $self->_curl_backend($curl);
+ }
+ } elsif ($scheme eq 'sftp') {
+ if ($self->{try_sftp} and my $sftp = $self->which('sftp')) {
+ $self->chat("You have $sftp\n");
+ # can't use /dev/fd/1 here, sftp need to seek...
+ my $output_file = "$self->{base}/sftp.tmp";
+ $backend = {
+ get => sub {
+ my($self, $uri) = @_;
+ $uri =~ s,^sftp://,,;
+ $self->safeexec( my $fh, $sftp, ( $self->{verbose} ? () : '-q' ), $uri, $output_file ) or die "sftp $uri: $!";
+ my $content = $self->file_get($output_file);
+ unlink $output_file;
+ return $content;
+ },
+ mirror => sub {
+ my($self, $uri, $path) = @_;
+ $uri =~ s,^sftp://,,;
+ $self->safeexec( my $fh, $sftp, ( $self->{verbose} ? () : '-q' ), $uri, $path ) or die "sftp $uri: $!";
+ local $/;
+ join '', <$fh>;
+ },
+ };
+ } elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
+ $self->chat("You have $curl\n");
+ $backend = $self->_curl_backend($curl);
+ }
+ }
+ # No included backend found, try to load one in
+ # App::cpanminus::backend:: namespace
+ unless (defined $backend) {
+ (my $module = $scheme) =~ tr/a-zA-Z0-9//cd;
+ substr($module, 0, 0, 'App::cpanminus::backend::');
+ $self->chat("Try to load external $scheme backend $module\n");
+ # The module must define 2 functions: 'get' & 'mirror'
+ eval "require $module" or die "Can't find a backend to handle `$scheme' scheme (loading $module failed)!\n";
+ $backend = {};
+ foreach my $func (qw(get mirror)) {
+ $backend->{$func} = $module->can($func) or die "$module does not implement $func function!\n";
+ }
+ }
+ $self->{_backends}{"/$scheme"} = $backend;
+ }
+ return $self->{_backends}{"/$scheme"};
+}
+
+sub get {
+ my($self, $uri) = @_;
+ return $self->get_scheme_backend($uri)->{get}->($self, $uri);
+}
+
+sub mirror {
+ my($self, $uri, $path) = @_;
+ return $self->get_scheme_backend($uri)->{mirror}->($self, $uri, $path);
+}
+
sub untar { $_[0]->{_backends}{untar}->(@_) };
sub unzip { $_[0]->{_backends}{unzip}->(@_) };
@@ -1719,78 +1918,6 @@ sub init_tools {
$self->chat("You have make $self->{make}\n");
}
- # use --no-lwp if they have a broken LWP, to upgrade LWP
- if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) {
- $self->chat("You have LWP $LWP::VERSION\n");
- my $ua = sub {
- LWP::UserAgent->new(
- parse_head => 0,
- env_proxy => 1,
- agent => "cpanminus/$VERSION",
- timeout => 30,
- @_,
- );
- };
- $self->{_backends}{get} = sub {
- my $self = shift;
- my $res = $ua->()->request(HTTP::Request->new(GET => $_[0]));
- return unless $res->is_success;
- return $res->decoded_content;
- };
- $self->{_backends}{mirror} = sub {
- my $self = shift;
- my $res = $ua->()->mirror(@_);
- $res->code;
- };
- } elsif ($self->{try_wget} and my $wget = $self->which('wget')) {
- $self->chat("You have $wget\n");
- $self->{_backends}{get} = sub {
- my($self, $uri) = @_;
- return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
- $self->safeexec( my $fh, $wget, $uri, ( $self->{verbose} ? () : '-q' ), '-O', '-' ) or die "wget $uri: $!";
- local $/;
- <$fh>;
- };
- $self->{_backends}{mirror} = sub {
- my($self, $uri, $path) = @_;
- return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
- $self->safeexec( my $fh, $wget, '--retry-connrefused', $uri, ( $self->{verbose} ? () : '-q' ), '-O', $path ) or die "wget $uri: $!";
- local $/;
- <$fh>;
- };
- } elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
- $self->chat("You have $curl\n");
- $self->{_backends}{get} = sub {
- my($self, $uri) = @_;
- return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
- $self->safeexec( my $fh, $curl, '-L', ( $self->{verbose} ? () : '-s' ), $uri ) or die "curl $uri: $!";
- local $/;
- <$fh>;
- };
- $self->{_backends}{mirror} = sub {
- my($self, $uri, $path) = @_;
- return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
- $self->safeexec( my $fh, $curl, '-L', $uri, ( $self->{verbose} ? () : '-s' ), '-#', '-o', $path ) or die "curl $uri: $!";
- local $/;
- <$fh>;
- };
- } else {
- require HTTP::Tiny;
- $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");
-
- $self->{_backends}{get} = sub {
- my $self = shift;
- my $res = HTTP::Tiny->new->get($_[0]);
- return unless $res->{success};
- return $res->{content};
- };
- $self->{_backends}{mirror} = sub {
- my $self = shift;
- my $res = HTTP::Tiny->new->mirror(@_);
- return $res->{status};
- };
- }
-
my $tar = $self->which('tar');
my $tar_ver;
my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
View
21 script/cpanm.PL
@@ -356,8 +356,25 @@ Uses cURL (if available) to download stuff. Defaults to true, and
you can say C<--no-curl> to disable using cURL.
Normally with C<--lwp>, C<--wget> and C<--curl> options set to true
-(which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny>
-(in that order) and uses the first one available.
+(which is the default) cpanm tries L<LWP>, Wget, cURL and
+L<HTTP::Tiny> (in that order) for C<ftp://>, C<http://> and
+C<https://> schemes and uses the first one available.
+
+=item --scp
+
+Use C<scp> command to download stuff for C<scp://> scheme.
+
+Normally with C<--curl> and C<--scp> options set to true (which is the
+default) cpanm tries C<scp> and cURL (in that order) for C<scp://>
+scheme.
+
+=item --sftp
+
+Use C<sftp> command to download stuff for C<sftp://> scheme.
+
+Normally with C<--curl> and C<--sftp> options set to true (which is
+the default) cpanm tries C<sftp> and cURL (in that order) for
+C<sftp://> scheme.
=back
Something went wrong with that request. Please try again.