Skip to content

Commit

Permalink
Merge pull request #666 from happy-barney/brz-dev-issue-657
Browse files Browse the repository at this point in the history 
Use path objects instead of strings
  • Loading branch information
@gugod
gugod committed May 9, 2019
2 parents 870a083 + 6d7a7dc commit ddbd141
Show file tree
Hide file tree
Showing 3 changed files with 262 additions and 3 deletions.
5 changes: 2 additions & 3 deletions lib/App/perlbrew.pm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1275,7 +1275,7 @@ sub do_install_git {
require File::Spec;
my $dist_extracted_dir = File::Spec->rel2abs($dist);
$self->do_install_this($dist_extracted_dir, $dist_version, "$dist_name-$dist_version");
$self->do_install_this(App::Perlbrew::Path->new ($dist_extracted_dir), $dist_version, "$dist_name-$dist_version");
return;
}
Expand Down Expand Up @@ -1467,7 +1467,6 @@ sub run_command_install {
my ($dist_type, $dist_version);
if (($dist_type, $dist_version) = $dist =~ /^(?:(c?perl)-?)?([\d._]+(?:-RC\d+)?|git|stable|blead)$/) {
my $dist_version = ($dist_version eq 'stable' ? $self->resolve_stable_version : $2);
$dist_version = $self->resolve_stable_version if $dist_version eq 'stable';
$dist_type ||= "perl";
$dist = "${dist_type}-${dist_version}"; # normalize dist name
Expand All @@ -1490,7 +1489,7 @@ sub run_command_install {
$self->do_install_git($dist);
}
elsif (-f $dist) {
$self->do_install_archive($dist);
$self->do_install_archive(App::Perlbrew::Path->new ($dist));
}
elsif ($dist =~ m/^(?:https?|ftp|file)/) { # more protocols needed?
$self->do_install_url($dist);
Expand Down
148 changes: 148 additions & 0 deletions t/command-install-from-archive.t
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,148 @@
#!/usr/bin/env perl
use strict;
use warnings;

use Test::Spec 0.49; # with_deep
use Test::Deep;

use FindBin;
use lib $FindBin::Bin;

use App::perlbrew;

use Hash::Util;

require 'test_helpers.pl';

sub arrange_file;
sub arrange_available_perls;
sub arrange_command_line;
sub expect_dispatch_via;
sub should_install_from_archive;
sub is_path;

describe "command install <archive>" => sub {
should_install_from_archive "with perl source archive" => (
filename => 'perl-5.28.0.tar.gz',
dist_version => '5.28.0',
installation_name => 'perl-5.28.0',
);

should_install_from_archive "with perfixed perl source archive" => (
filename => 'downloaded-perl-5.28.0.tar.gz',
dist_version => '5.28.0',
installation_name => 'perl-5.28.0',
);

should_install_from_archive "with cperl source archive" => (
filename => 'cperl-5.28.0.tar.gz',
dist_version => '5.28.0',
installation_name => 'cperl-5.28.0',
);

should_install_from_archive "with prefixed cperl source archive" => (
filename => 'downloaded-cperl-5.28.0.tar.gz',
dist_version => '5.28.0',
installation_name => 'cperl-5.28.0',
);

};

runtests unless caller;

sub should_install_from_archive {
my ($title, %params) = @_;

Hash::Util::lock_keys %params,
'filename',
'dist_version',
'installation_name',
;

context $title => sub {
my $file;

before each => sub {
$file = arrange_file
name => $params{filename},,
tempdir => 1,
;

arrange_command_line install => $file;
};

expect_dispatch_via
method => 'do_install_archive',
with_args => [
is_path (methods (basename => $params{filename}))
];

expect_dispatch_via method => 'do_extract_tarball',
stubs => { do_install_this => '' },
with_args => [
is_path (methods (basename => $params{filename}))
];

expect_dispatch_via method => 'do_install_this',
stubs => { do_extract_tarball => sub { $_[-1]->dirname->child ('foo') } },
with_args => [
is_path (methods (basename => 'foo')),
$params{dist_version},
$params{installation_name},
];
};
};

sub is_path {
my (@tests) = @_;

all (
obj_isa ('App::Perlbrew::Path'),
@tests,
);
}

sub arrange_file {
my (%params) = @_;

my $dir;
$dir ||= $params{dir} if $params{dir};
$dir ||= tempdir (CLEANUP => 1) if $params{tempdir};
$dir ||= '.';

my $file = file ($dir, $params{name});

open my $fh, '>', $file;
close $fh;

return $file;
}

sub arrange_command_line {
my (@command_line) = @_;

share my %shared;

# Enforce stringification
$shared{app} = App::perlbrew->new (map "$_", @command_line);
}

sub expect_dispatch_via {
my (%params) = @_;

it "should dispatch via $params{method}()" => sub {
share my %shared;

App::perlbrew->stubs (%{ $params{stubs} })
if $params{stubs};

my $expectation = App::perlbrew->expects ($params{method});
$expectation = $expectation->with_deep (@{ $params{with_args} })
if $params{with_args};

$shared{app}->run;

ok $expectation->verify;
};
}

112 changes: 112 additions & 0 deletions t/command-install.t
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,112 @@
#!/usr/bin/env perl
use strict;
use warnings;

use Test::Spec 0.49; # with_deep
use Test::Deep;

use FindBin;
use lib $FindBin::Bin;

use App::perlbrew;

require 'test_helpers.pl';

sub arrange_available_perls;
sub arrange_command_line;
sub expect_dispatch_via;

describe "command install" => sub {
it "should install exact perl version" => sub {
arrange_command_line install => 'perl-5.12.1';

expect_dispatch_via do_install_release => [ 'perl-5.12.1', '5.12.1' ];
};

it "should install exact cperl version" => sub {
arrange_command_line install => 'cperl-5.26.4';

expect_dispatch_via do_install_release => [ 'cperl-5.26.4', '5.26.4' ];
};

it "should install stable version of perl" => sub {
arrange_command_line install => 'perl-stable';

arrange_available_perls qw[
perl-5.12.2
perl-5.12.3
perl-5.14.1
perl-5.14.2
perl-5.29.0
];

expect_dispatch_via do_install_release => [ 'perl-5.14.2', '5.14.2' ];
};

it "should install blead perl" => sub {
arrange_command_line install => 'perl-blead';

expect_dispatch_via do_install_blead => [ 'perl-blead' ];
};

it "should install git checkout" => sub {
my $checkout = tempdir (CLEANUP => 1);
dir ($checkout, '.git')->mkpath;

arrange_command_line install => $checkout;

expect_dispatch_via do_install_git => [ $checkout ];
};

it "should install from archive" => sub {
my $checkout = tempdir (CLEANUP => 1);
my $file = file ($checkout, 'archive.tar.gz')->stringify;

open my $fh, '>', $file;
close $fh;

arrange_command_line install => $file;

expect_dispatch_via do_install_archive => [ all (
obj_isa ('App::Perlbrew::Path'),
methods (stringify => $file),
) ];
};

it "should install from uri" => sub {
arrange_command_line install => 'http://example.com/foo/bar';

expect_dispatch_via do_install_url => [ 'http://example.com/foo/bar' ];
};
};

runtests unless caller;

sub arrange_available_perls {
my (@list) = @_;

App::perlbrew->stubs (available_perls => sub { $_[0]->sort_perl_versions (@list) });
}

sub arrange_command_line {
my (@command_line) = @_;

share my %shared;

$shared{app} = App::perlbrew->new (@command_line);
}

sub expect_dispatch_via {
my ($method, $arguments) = @_;

share my %shared;

my $expectation = App::perlbrew->expects ($method);
$expectation = $expectation->with_deep (@$arguments)
if $arguments;


$shared{app}->run;

ok $expectation->verify;
}

0 comments on commit ddbd141

Please sign in to comment.