Skip to content

Commit

Permalink
Merge 5c98715 into ed51e67
Browse files Browse the repository at this point in the history
  • Loading branch information
@gugod
gugod committed Jun 30, 2021
2 parents ed51e67 + 5c98715 commit 8ce6923
Show file tree
Hide file tree
Showing 3 changed files with 102 additions and 93 deletions.
126 changes: 48 additions & 78 deletions lib/App/perlbrew.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,6 +23,7 @@ use Getopt::Long ();
use CPAN::Perl::Releases;
use JSON::PP 'decode_json';
use File::Copy 'copy';
use Capture::Tiny ();

use App::Perlbrew::Util;
use App::Perlbrew::Path;
Expand Down Expand Up @@ -1776,7 +1777,6 @@ sub do_system {
sub do_capture {
my ($self, @cmd) = @_;
require Capture::Tiny;
return Capture::Tiny::capture(
sub {
$self->do_system(@cmd);
Expand Down Expand Up @@ -2303,20 +2303,19 @@ sub run_command_exec {
} split $d, $opts{with};
@exec_with = map { $installed{$_} } @with;
}
else {
} else {
@exec_with = map { ($_, @{$_->{libs}}) } $self->installed_perls;
}
if ($opts{min}) {
# TODO use comparable version.
# For now, it doesn't produce consistent results for 5.026001 and 5.26.1
@exec_with = grep { $_->{orig_version} >= $opts{min} } @exec_with;
};
}
if ($opts{max}) {
@exec_with = grep { $_->{orig_version} <= $opts{max} } @exec_with;
};
}
if (0 == @exec_with) {
print "No perl installation found.\n" unless $self->{quiet};
Expand Down Expand Up @@ -2351,8 +2350,8 @@ sub run_command_exec {
print "Command terminated with non-zero status.\n";
print STDERR "Command [" .
join(' ', map { /\s/ ? "'$_'" : $_ } @ARGV) . # trying reverse shell escapes - quote arguments containing spaces
"] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n";
join(' ', map { /\s/ ? "'$_'" : $_ } @ARGV) . # trying reverse shell escapes - quote arguments containing spaces
"] terminated with exit code $exit_code (\$? = $err) under the following perl environment:\n";
print STDERR $self->format_info_output;
}
Expand Down Expand Up @@ -2406,17 +2405,15 @@ sub run_command_alias {
$path_alias->unlink;
$path_name->symlink ($path_alias);
}
elsif ($cmd eq 'delete') {
} elsif ($cmd eq 'delete') {
$self->assert_known_installation($name);
unless (-l $path_name) {
die "\nABORT: The installation name `$name` is not an alias, cannot remove.\n\n";
}
$path_name->unlink;
}
elsif ($cmd eq 'rename') {
} elsif ($cmd eq 'rename') {
$self->assert_known_installation($name);
unless (-l $path_name) {
Expand All @@ -2428,11 +2425,9 @@ sub run_command_alias {
}
rename($path_name, $path_alias);
}
elsif ($cmd eq 'help') {
} elsif ($cmd eq 'help') {
$self->run_command_help("alias");
}
else {
} else {
die "\nERROR: Unrecognized action: `${cmd}`.\n\n";
}
}
Expand Down Expand Up @@ -2460,8 +2455,7 @@ sub run_command_lib {
my $sub = "run_command_lib_$subcommand";
if ($self->can($sub)) {
$self->$sub(@args);
}
else {
} else {
print "Unknown command: $subcommand\n";
}
}
Expand Down Expand Up @@ -2490,7 +2484,7 @@ sub run_command_lib_create {
$dir->mkpath;
print "lib '$fullname' is created.\n"
unless $self->{quiet};
unless $self->{quiet};
return;
}
Expand Down Expand Up @@ -2519,9 +2513,8 @@ sub run_command_lib_delete {
$dir->rmpath;
print "lib '$fullname' is deleted.\n"
unless $self->{quiet};
}
else {
unless $self->{quiet};
} else {
die "ERROR: '$fullname' does not exist.\n";
}
Expand Down Expand Up @@ -2603,37 +2596,44 @@ sub run_command_upgrade_perl {
$self->do_install_release($dist, $dist_version);
}
# Executes the list-modules command.
# This routine launches a new perl instance that, thru
# ExtUtils::Installed prints out all the modules
# in the system. If an argument is passed to the
# subroutine it is managed as a filename
# to which prints the list of modules.
sub run_command_list_modules {
my ($self, $output_filename) = @_;
my $class = ref($self) || __PACKAGE__;
sub list_modules {
my ($self, $env) = @_;
# avoid something that does not seem as a filename to print
# output to...
undef $output_filename if (! scalar($output_filename));
$env ||= $self->current_env;
my ($stdout, $stderr, $success) = Capture::Tiny::capture(
sub {
__PACKAGE__->new(
"--quiet", "exec", "--with", $env, 'perl', '-MExtUtils::Installed', '-le',
'BEGIN{@INC=grep {$_ ne q!.!} @INC}; print for ExtUtils::Installed->new->modules;',
)->run;
}
);
my $name = $self->current_env;
if (-l (my $path = $self->root->perls ($name))) {
$name = $path->readlink->basename;
unless ($success) {
unless ($self->{quiet}) {
print STDERR "Failed to retrive the list of installed modules.\n";
if ($self->{verbose}) {
print STDERR "STDOUT\n======\n$stdout\nSTDERR\n======\n$stderr\n";
}
}
return [];
}
my $app = $class->new(
qw(--quiet exec --with),
$name,
'perl',
'-MExtUtils::Installed',
'-le',
sprintf('BEGIN{@INC=grep {$_ ne q!.!} @INC}; %s print {%s} $_ for grep {$_ ne q!Perl!} ExtUtils::Installed->new->modules;',
$output_filename ? sprintf('open my $output_fh, \'>\', "%s"; ', $output_filename) : '',
$output_filename ? '$output_fh' : 'STDOUT')
my %rename = (
"ack" => "App::Ack",
"libwww::perl" => "LWP",
"libintl-perl" => "Locale::Messages",
"Role::Identifiable" => "Role::Identifiable::HasTags",
"TAP::Harness::Multiple" => "TAP::Harness::ReportByDescription",
);
$app->run;
return [map { $rename{$_} // $_ } grep { $_ ne "Perl" } split(/\n/, $stdout)];
}
sub run_command_list_modules {
my ($self) = @_;
my ($modules, $error) = $self->list_modules();
print "$_\n" for @$modules;
}
sub resolve_installation_name {
Expand Down Expand Up @@ -2692,7 +2692,6 @@ sub run_command_clone_modules {
$dst_perl = pop || $self->current_env;
$src_perl = pop || $self->current_env;
# check source and destination do exist
undef $src_perl if (! $self->resolve_installation_name($src_perl));
undef $dst_perl if (! $self->resolve_installation_name($dst_perl));
Expand All @@ -2706,37 +2705,8 @@ sub run_command_clone_modules {
exit(-1);
}
my @modules_to_install = @{ $self->list_modules($src_perl) };
# I need to run an application to do the module listing.
# and get the result back so to handle it and pass
# to the exec subroutine. The solution I found so far
# is to store the result in a temp file (the list_modules
# uses a sub-perl process, so there is no way to pass a
# filehandle or something similar).
my $class = ref($self);
require File::Temp;
my $modules_fh = File::Temp->new;
# list all the modules and place them in the output file
my $src_app = $class->new(
qw(--quiet exec --with),
$src_perl,
'perl',
'-MExtUtils::Installed',
'-le',
sprintf('BEGIN{@INC=grep {$_ ne q!.!} @INC}; open my $output_fh, ">", "%s"; print {$output_fh} $_ for ExtUtils::Installed->new->modules;',
$modules_fh->filename )
);
$src_app->run;
# here I should have the list of modules into the
# temporary file name, so I can ask the destination
# perl instance to install such list
$modules_fh->close;
open $modules_fh, '<', $modules_fh->filename;
chomp(my @modules_to_install = <$modules_fh>);
$modules_fh->close;
die "\nNo modules installed on $src_perl !\n" if (! @modules_to_install);
print "\nInstalling $#modules_to_install modules from $src_perl to $dst_perl ...\n";
Expand All @@ -2751,7 +2721,7 @@ sub run_command_clone_modules {
push @args, '--notest' if $self->{notest};
push @args, @modules_to_install;
$class->new(@args)->run;
__PACKAGE__->new(@args)->run;
}
sub format_info_output
Expand Down
22 changes: 7 additions & 15 deletions t/command-clone-modules.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,23 +16,15 @@ mock_perlbrew_install("perl-5.16.0");

no warnings;
my ($__from, $__to, $__notest);
sub App::perlbrew::list_modules {
my ($self, $env) = @_;
$__from = $env || $self->current_env;
return ["Foo", "Bar"];
}

sub App::perlbrew::run_command_exec {
my ($self, @args) = @_;

diag "ARGS: @args";

if (grep { $_ eq '-MExtUtils::Installed' } @args) {
$__from = $args[1];

my ($fn) = $args[5] =~ m{open .+">", "(.+?)";};
if ($fn) {
open my $fh, ">", $fn;
print $fh "Foo\nBar\n";
close($fh);
} else {
die "Failed to grok output path.";
}
} elsif (grep { $_ eq 'cpanm' } @args) {
if (grep { $_ eq 'cpanm' } @args) {
$__to = $args[1];
($__notest) = grep { $_ eq '--notest' } @{$self->{original_argv}};
}
Expand Down
47 changes: 47 additions & 0 deletions t/list_modules.t
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,47 @@
#!/usr/bin/env perl
use strict;
use warnings;

use FindBin;
use lib $FindBin::Bin;
use App::perlbrew;
require "test_helpers.pl";

use Test::Spec;

mock_perlbrew_install("perl-5.14.1");

describe "list_modules method," => sub {
before each => sub {
delete $ENV{PERL_MB_OPT};
delete $ENV{PERL_MM_OPT};
delete $ENV{PERL_LOCAL_LIB_ROOT};
delete $ENV{PERLBREW_LIB};
delete $ENV{PERL5LIB};
};

describe "when run successfully", sub {
before each => sub {
no warnings;
sub App::perlbrew::run_command_exec {
my ($self, @args) = @_;
if (grep { $_ eq '-MExtUtils::Installed' } @args) {
print "Foo\n";
} else {
die "Unexpected `exec`";
}
return $self;
}
};

it "should return an arryref of module names ", sub {
my $app = App::perlbrew->new();
$app->current_perl("perl-5.14.1");
my $modules = $app->list_modules();
is 0+@$modules, 1;
is $modules->[0], "Foo";
};
};
};

runtests unless caller;

0 comments on commit 8ce6923

Please sign in to comment.