From b21ce10e7ddf05cf8ea4a57531ee8d21ade24bf1 Mon Sep 17 00:00:00 2001 From: Roy Storey Date: Thu, 15 Feb 2018 10:17:16 +1300 Subject: [PATCH] improve _make_name and extended tests --- lib/Devel/IPerl/Plugin/Perlbrew.pm | 45 +++++++++--- t/iperl-perlbrew.t | 111 ++++++++++++++++++++--------- t/lib/Test/App/perlbrew.pm | 49 +++++++++++-- 3 files changed, 156 insertions(+), 49 deletions(-) diff --git a/lib/Devel/IPerl/Plugin/Perlbrew.pm b/lib/Devel/IPerl/Plugin/Perlbrew.pm index fa52e97..91e11cc 100644 --- a/lib/Devel/IPerl/Plugin/Perlbrew.pm +++ b/lib/Devel/IPerl/Plugin/Perlbrew.pm @@ -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}); } @@ -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 diff --git a/t/iperl-perlbrew.t b/t/iperl-perlbrew.t index 668e03a..6326763 100644 --- a/t/iperl-perlbrew.t +++ b/t/iperl-perlbrew.t @@ -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'; @@ -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}; @@ -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, @@ -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; diff --git a/t/lib/Test/App/perlbrew.pm b/t/lib/Test/App/perlbrew.pm index ebbf8f7..6069439 100644 --- a/t/lib/Test/App/perlbrew.pm +++ b/t/lib/Test/App/perlbrew.pm @@ -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 { @@ -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 {