briefly check if current system looks might be incompatible with the …

…given tarball url.
gugod · Sep 22, 2024 · e218912 · e218912
1 parent 596454a
commit e218912
Show file tree

Hide file tree

Showing 3 changed files with 68 additions and 4 deletions.
diff --git a/lib/App/Perlbrew/Util.pm b/lib/App/Perlbrew/Util.pm
@@ -5,7 +5,7 @@ use 5.008;
 
 use Exporter 'import';
 our @EXPORT = qw( uniq min editdist files_are_the_same perl_version_to_integer );
-our @EXPORT_OK = qw( find_similar_tokens looks_like_url_of_skaji_relocatable_perl );
+our @EXPORT_OK = qw( find_similar_tokens looks_like_url_of_skaji_relocatable_perl looks_like_sys_would_be_compatible_with_skaji_relocatable_perl );
 
 sub uniq {
  my %seen;
@@ -114,4 +114,22 @@ sub looks_like_url_of_skaji_relocatable_perl {
  };
 }
 
+
+sub _arch_compat {
+ my ($arch) = @_;
+ my $compat = {
+ x86_64 => "amd64"
+ };
+ return $compat->{$arch} || $arch;
+}
+
+sub looks_like_sys_would_be_compatible_with_skaji_relocatable_perl {
+ my ($detail, $sys) = @_;
+
+ return (
+ ($detail->{os} eq $sys->os)
+ && (_arch_compat($detail->{arch}) eq _arch_compat($sys->arch))
+ );
+}
+
 1;
diff --git a/lib/App/perlbrew.pm b/lib/App/perlbrew.pm
@@ -24,7 +24,7 @@ use JSON::PP qw( decode_json );
 use File::Copy qw( copy move );
 use Capture::Tiny ();
 
-use App::Perlbrew::Util qw( files_are_the_same uniq find_similar_tokens looks_like_url_of_skaji_relocatable_perl );
+use App::Perlbrew::Util qw( files_are_the_same uniq find_similar_tokens looks_like_url_of_skaji_relocatable_perl looks_like_sys_would_be_compatible_with_skaji_relocatable_perl);
 use App::Perlbrew::Path ();
 use App::Perlbrew::Path::Root ();
 use App::Perlbrew::HTTP qw( http_download http_get );
@@ -1231,7 +1231,11 @@ sub run_command_install {
  }
 
  if ( my $detail = looks_like_url_of_skaji_relocatable_perl($dist) ) {
- return $self->do_install_skaji_relocatable_perl($detail);
+ if (looks_like_sys_would_be_compatible_with_skaji_relocatable_perl($detail, $self->sys)) {
+ return $self->do_install_skaji_relocatable_perl($detail);
+ } else {
+ die "ERROR: The given url points to a tarball for different os/arch.\n";
+ }
  }
 
  $self->{dist_name} = $dist; # for help msg generation, set to non

diff --git a/t/util-looks-like.t b/t/util-looks-like.t
@@ -1,5 +1,5 @@
 use Test2::V0;
-use App::Perlbrew::Util qw(looks_like_url_of_skaji_relocatable_perl);
+use App::Perlbrew::Util qw(looks_like_url_of_skaji_relocatable_perl looks_like_sys_would_be_compatible_with_skaji_relocatable_perl);
 
 subtest "looks_like_url_of_skaji_relocatable_perl", sub {
  is(
@@ -29,4 +29,46 @@ subtest "looks_like_url_of_skaji_relocatable_perl", sub {
  );
 };
 
+subtest "looks_like_sys_would_be_compatible_with_skaji_relocatable_perl", sub {
+ my $detail = looks_like_url_of_skaji_relocatable_perl("https:/skaji/relocatable-perl/releases/download/5.40.0.0/perl-linux-amd64.tar.gz");
+
+ my @positiveCases = (
+ (mock {} =>
+ add => [
+ os => sub { "linux" },
+ arch => sub { "amd64" },
+ ]),
+ (mock {} =>
+ add => [
+ os => sub { "linux" },
+ arch => sub { "x86_64" },
+ ]),
+ );
+
+ my @negativeCasse = (
+ (mock {} =>
+ add => [
+ os => sub { "linux" },
+ arch => sub { "arm64" },
+ ]),
+ (mock {} =>
+ add => [
+ os => sub { "darwin" },
+ arch => sub { "aarch64" },
+ ]),
+ (mock {} =>
+ add => [
+ os => sub { "darwin" },
+ arch => sub { "x86_64" },
+ ]),
+ );
+
+
+ is looks_like_sys_would_be_compatible_with_skaji_relocatable_perl($detail, $_), T()
+ for @positiveCases;
+
+ is looks_like_sys_would_be_compatible_with_skaji_relocatable_perl($detail, $_), F()
+ for @negativeCasse;
+};
+
 done_testing;