Skip to content

Commit

Permalink
improve _make_name and extended tests
Browse files Browse the repository at this point in the history
  • Loading branch information
@kiwiroy
kiwiroy committed Feb 14, 2018
1 parent a0209bc commit b21ce10
Show file tree
Hide file tree
Showing 3 changed files with 156 additions and 49 deletions.
45 changes: 37 additions & 8 deletions lib/Devel/IPerl/Plugin/Perlbrew.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -154,6 +154,13 @@ sub success { scalar(keys %{$_[0]->{env}}) ? 1 : 0; }

sub unload { return $_[0]{unload} if @_ == 1; $_[0]{unload} = $_[1]; $_[0]; }

sub _check_env_perl {
my ($env_perl, $path_perl) = (shift, _from_binary_path());
$ENV{PERLBREW_PERL} = $env_perl = $path_perl unless $env_perl;
return $env_perl unless $path_perl;
return ($env_perl eq $path_perl ? $env_perl : $ENV{PERLBREW_PERL} = $path_perl);
}

sub _filtered_env_keys {
return (sort grep { m/^PERL/i && $_ ne "PERL5LIB" } keys %{+pop});
}
Expand All @@ -167,19 +174,41 @@ sub _from_binary_path {

sub _make_name {
my ($class, $name, $current) =
(shift, shift, $ENV{PERLBREW_PERL} || _from_binary_path());
my ($perl, $lib) =
split /\@/, ($name =~ m/\@/ || $name eq $current ? $name : "\@$name");
$perl = $class->_resolve_compat($perl) || $current;
(shift, shift, _check_env_perl($ENV{PERLBREW_PERL}));
my $pb = PERLBREW_CLASS->new();
my ($perl, $lib) = $pb->resolve_installation_name($name);
if ((! defined($perl))){
if ($name =~ m/\@[^\@]+$/) {
($perl, $lib) = $pb->resolve_installation_name(join '@', $current, (split /\@/, $name)[1]);
} elsif($name !~ /\@/ && $name !~ /^[\d\.]+$/){
($perl, $lib) = $pb->resolve_installation_name(join '@', $current, $name);
}
}
$perl = $class->_resolve_compat($pb, $perl, $current, $lib) || $current;
return $perl unless $lib;
return join '@', $perl, $lib;
}

sub _resolve_compat {
my ($class, $perl) = (shift, shift);
my $pb = PERLBREW_CLASS->new;
my ($current) = grep { $_->{is_current} } $pb->installed_perls;
return $pb->resolve_installation_name($current->{version}) || '';
my ($class, $pb, $perl, $current, $lib) = @_;
return '' unless $lib;
my @installed = $pb->installed_perls;
# get the current perl and version
my ($current_perl) = grep { $_->{name} eq $current } @installed;
my $current_version = $current_perl->{comparable_version};

my ($avail) = (
# filter the exact
grep { $_->{perl_name} eq $perl && $_->{lib_name} eq $lib }
# get the libraries only
map { @{$_->{libs}} }
# filter the compatible libraries
grep { $_->{comparable_version} == $current_version } @installed
);
#use Data::Dumper;
#say STDERR Dumper $current_perl, $current_version, \@installed if DEBUG;
return '' unless $avail;
return $avail->{perl_name};
}

## from Mojo::Util
Expand Down
111 changes: 77 additions & 34 deletions t/iperl-perlbrew.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -9,36 +9,15 @@ use Devel::IPerl;
use IPerl;
use lib 't/lib';

sub test_perlbrew_perl {
(my $perl = $^V->normal) =~ s{^v}{perl-};
return $perl;
}

my $iperl = new_ok('IPerl');

ok $iperl->load_plugin('Perlbrew');
my $domain = $ENV{PERLBREW_HOME} || '';

my $iperl = new_ok('IPerl');
ok $iperl->load_plugin('Perlbrew');
can_ok $iperl, qw{perlbrew perlbrew_domain perlbrew_lib_create perlbrew_list
perlbrew_list_modules};

is $iperl->perlbrew(), -1, 'no library for app::perlbrew';

my $save = $ENV{PERLBREW_ROOT};

is $iperl->perlbrew('random1'), 1, 'here';
is $iperl->perlbrew('random2'), 1, 'here';
is $iperl->perlbrew('random2'), 0, 'here';

is $ENV{PERLBREW_ROOT}, $save, 'no change';
is $ENV{PERLBREW_HOME}, '/tmp', 'set';

is $iperl->perlbrew_domain, $domain, 'domain from register';
is $iperl->perlbrew_domain('/tmp'), '/tmp', 'domain set';

my @added = grep { m{^\Q$Test::App::perlbrew::PERL5LIB\E$} } @INC;
is @added, 1, "contains path '$Test::App::perlbrew::PERL5LIB'";

#
# Test the internal plugin interface first
#
my $plugin = new_ok('Devel::IPerl::Plugin::Perlbrew');
is $plugin->name, undef, 'empty default';
is $plugin->name('perl-5.26.0@random'), $plugin, 'chaining';
Expand Down Expand Up @@ -91,16 +70,59 @@ $plugin->new(name => 'foo')->new({name => 'bar'})->brew;

# _make_name tests check various constraints
{
local $ENV{PERLBREW_PERL} = $ENV{PERLBREW_PERL} || test_perlbrew_perl();
(my $current_perl = $^X) =~ s{.*/perls/([^/]+)/bin/perl}{$1};
is $plugin->_make_name('foo'), join('@', $ENV{PERLBREW_PERL}, 'foo'),
'make name';
is $plugin->_make_name($ENV{PERLBREW_PERL}), $ENV{PERLBREW_PERL},
'current perl';
local $ENV{PERLBREW_PERL} = 'perl-alias';
(local $^X = $^X) =~ s{perls/([^/]+)/bin}{perls/perl-alias/bin};

is $plugin->_make_name('alias@example'), 'perl-alias@example',
'perl match current with existing lib';
is $plugin->_make_name('alias@lib'), 'perl-alias@lib',
'perl match current with new lib';
is $plugin->_make_name('5.26.0@random'), 'perl-5.26.0@random',
'perl with same version, and existing lib';
## the current perl is preferred when neither have the library.
is $plugin->_make_name('5.26.0@example'), 'perl-alias@example',
'perl with same version, and new lib - these cannot be created';
## cannot switch to this library free compatible perl
is $plugin->_make_name('5.26.0'), 'perl-alias',
'installed perl with no lib - cannot be accessed';

is $plugin->_make_name('5.24.0'), 'perl-alias',
'non installed perl with no lib';
is $plugin->_make_name('alias'), 'perl-alias',
'shortened name with no lib';
is $plugin->_make_name('alias@random'), 'perl-alias@random', '';
is $plugin->_make_name('5.26.0@random'), 'perl-5.26.0@random', '';

# some helpful versions
is $plugin->_make_name('foo-bar-baz'), 'perl-alias@foo-bar-baz',
'no perl, just a libray (new), without @';
is $plugin->_make_name('foo'), 'perl-alias@foo',
'no perl, just a libray, without @';
is $plugin->_make_name('@foo'), 'perl-alias@foo',
'no perl, just a libray, explicitly with @';
is $plugin->_make_name('bad@'), 'perl-alias',
'trailing @ is in no way supported';
is $plugin->_make_name('rad@rad@rad'), 'perl-alias@rad',
'multiple @ will take the element at position 1';
}

{
local $ENV{PERLBREW_PERL} = 'perl-5.8.9';
(local $^X = $^X) =~ s{perls/([^/]+)/bin}{perls/perl-5.8.9/bin};
is $plugin->_make_name('5.8.9@random'), 'perl-5.8.9@random',
'perl match current with new lib';
is $plugin->_make_name('5.8.8@archive'), 'perl-5.8.9@archive',
'perl match current with new lib';
is $plugin->_make_name('5.26.0@random'), 'perl-5.8.9@random',
'perl with different version, and existing lib';
is $plugin->_make_name('5.26.0'), 'perl-5.8.9',
'installed perl with no lib - cannot be accessed';

}

{
local $ENV{PERLBREW_PERL} = 'perl-5.24.3';
(local $^X = $^X) =~ s{perls/([^/]+)/bin}{perls/perl-5.24.3/bin};
is $plugin->_make_name('bar'), 'perl-5.24.3@bar', 'make name';
is $plugin->_make_name('perl-5.26.1@bar'), 'perl-5.24.3@bar', 'make name';
delete $ENV{PERLBREW_PERL};
Expand All @@ -112,12 +134,32 @@ $plugin->new(name => 'foo')->new({name => 'bar'})->brew;
'non-numeric "current" perl';
## default to perl version
$^X =~ s{perls/([^/]+)/bin}{p/perl-alias/bin};
my $version = test_perlbrew_perl();
(my $version = $^V->normal) =~ s{^v}{perl-};
is $plugin->_make_name('bar'), join('@', $version, 'bar'), 'make name';
is $plugin->_make_name('perl-5.26.1@bar'), join('@', $version, 'bar'),
'make name';
}

#
# Now to working on the functionality of plugin functions
#
is $iperl->perlbrew(), -1, 'no library for app::perlbrew';

my $save = $ENV{PERLBREW_ROOT};

is $iperl->perlbrew('random1'), 1, 'here';
is $iperl->perlbrew('random2'), 1, 'here';
is $iperl->perlbrew('random2'), 0, 'here';

is $ENV{PERLBREW_ROOT}, $save, 'no change';
is $ENV{PERLBREW_HOME}, '/tmp', 'set';

is $iperl->perlbrew_domain, $domain, 'domain from register';
is $iperl->perlbrew_domain('/tmp'), '/tmp', 'domain set';

my @added = grep { m{^\Q$Test::App::perlbrew::PERL5LIB\E$} } @INC;
is @added, 1, "contains path '$Test::App::perlbrew::PERL5LIB'";

is $iperl->perlbrew_lib_create(), -1, 'no lib in lib_create';
is $iperl->perlbrew_lib_create('special'), 1, 'lib_create';
is $iperl->perlbrew_lib_create('test-library'), 0,
Expand All @@ -143,5 +185,6 @@ is $INC{'ACME/NotThere.pm'}, undef, 'not in %INC';
eval "ACME::NotThere->heres_johnny;";
like $@, qr/heres_johnny/, 'nope';


# use Data::Dumper;
# diag Dumper [ Test::App::perlbrew->installed_perls ] ;
done_testing;
49 changes: 42 additions & 7 deletions t/lib/Test/App/perlbrew.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -14,13 +14,38 @@ sub new { bless {}, $_[0]; }

sub home {
}

sub comparable_perl_version {
shift;
require App::perlbrew;
(
App::perlbrew->comparable_perl_version(@_)
);
}
sub installed_perls {
return {
name => $ENV{PERLBREW_PERL},
version => ((my $a = $ENV{PERLBREW_PERL} || '') =~ s/^perl\-//),
is_current => 1,
};
my $self = shift;
my @result;
(my $version = $^V->normal) =~ s{^v}{perl-};
my %perlset = (
$version => [$self->comparable_perl_version($version)],
'perl-5.26.0' => [5260000, qw{foo bar random random1 random2}],
'perl-5.24.3' => [5240300, qw{bar}],
'perl-alias' => [5260000, qw{example}],
'perl-5.8.9' => [5080900, qw{archived}],
);
for my $perl(keys %perlset){
my $inst = {
name => $perl, comparable_version => shift(@{$perlset{$perl}}), libs => []
};
for my $lib(@{$perlset{$perl}}) {
push @{$inst->{libs}}, {
name => join('@', $perl, $lib), lib_name => $lib, perl_name => $perl
};
}
push @result, $inst;
}
# use Data::Dumper;
# warn Dumper \@result;
return @result;
}

sub perlbrew_env {
Expand All @@ -35,7 +60,17 @@ sub perlbrew_env {
}

sub resolve_installation_name {

my ($self, $name) = @_;
my ($perl, $lib) = split '@', $name, 2;
my @installed = $self->installed_perls;
if (0 == grep { $_->{name} eq $perl} @installed) {
if (grep { $_->{name} eq "perl-$perl" } @installed) {
$perl = "perl-$perl";
} else {
return undef
}
}
return ($perl, $lib);
}

sub run_command {
Expand Down

0 comments on commit b21ce10

Please sign in to comment.