1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
|
package App::Perlbrew::Util;
use strict;
use warnings;
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
looks_like_sys_would_be_compatible_with_skaji_relocatable_perl
make_skaji_relocatable_perl_url
);
sub uniq {
my %seen;
grep { !$seen{$_}++ } @_;
}
sub min(@) {
my $m = $_[0];
for(@_) {
$m = $_ if $_ < $m;
}
return $m;
}
# straight copy of Wikipedia's "Levenshtein Distance"
sub editdist {
my @a = split //, shift;
my @b = split //, shift;
# There is an extra row and column in the matrix. This is the
# distance from the empty string to a substring of the target.
my @d;
$d[$_][0] = $_ for (0 .. @a);
$d[0][$_] = $_ for (0 .. @b);
for my $i (1 .. @a) {
for my $j (1 .. @b) {
$d[$i][$j] = ($a[$i-1] eq $b[$j-1] ? $d[$i-1][$j-1]
: 1 + min($d[$i-1][$j], $d[$i][$j-1], $d[$i-1][$j-1]));
}
}
return $d[@a][@b];
}
sub files_are_the_same {
## Check dev and inode num. Not useful on Win32.
## The for loop should always return false on Win32, as a result.
my @files = @_;
my @stats = map {[ stat($_) ]} @files;
my $stats0 = join " ", @{$stats[0]}[0,1];
for (@stats) {
return 0 if ((! defined($_->[1])) || $_->[1] == 0);
unless ($stats0 eq join(" ", $_->[0], $_->[1])) {
return 0;
}
}
return 1
}
sub perl_version_to_integer {
my $version = shift;
my @v;
if ($version eq 'blead') {
@v = (999,999,999);
} else {
@v = split(/[\.\-_]/, $version);
}
return undef if @v < 2;
if ($v[1] <= 5) {
$v[2] ||= 0;
$v[3] = 0;
}
else {
$v[3] ||= $v[1] >= 6 ? 9 : 0;
$v[3] =~ s/[^0-9]//g;
}
return $v[1]*1000000 + $v[2]*1000 + $v[3];
}
sub find_similar_tokens {
my ($token, $tokens) = @_;
my $SIMILAR_DISTANCE = 6;
my @similar_tokens = sort { $a->[1] <=> $b->[1] } map {
my $d = editdist( $_, $token );
( ( $d < $SIMILAR_DISTANCE ) ? [$_, $d] : () )
} @$tokens;
if (@similar_tokens) {
my $best_score = $similar_tokens[0][1];
@similar_tokens = map { $_->[0] } grep { $_->[1] == $best_score } @similar_tokens;
}
return \@similar_tokens;
}
sub looks_like_url_of_skaji_relocatable_perl {
my ($str) = @_;
# https://github.com/skaji/relocatable-perl/releases/download/5.40.0.0/perl-linux-amd64.tar.gz
my $prefix = "https://github.com/skaji/relocatable-perl/releases/download";
my $version_re = qr/(5\.[0-9][0-9]\.[0-9][0-9]?.[0-9])/;
my $name_re = qr/perl-(linux|darwin)-(amd64|arm64)\.tar\.gz/;
return undef unless $str =~ m{ \Q$prefix\E / $version_re / $name_re }x;
return {
url => $str,
version => $1,
os => $2,
arch => $3,
original_filename => "perl-$2-$3.tar.gz",
};
}
sub _arch_compat {
my ($arch) = @_;
my $compat = {
x86_64 => "amd64",
i386 => "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))
);
}
sub make_skaji_relocatable_perl_url {
my ($str, $sys) = @_;
if ($str =~ m/\Askaji-relocatable-perl-(5\.[0-9][0-9]\.[0-9][0-9]?.[0-9])\z/) {
my $version = $1;
my $os = $sys->os;
my $arch = $sys->arch;
$arch = "amd64" if $arch eq 'x86_64' || $arch eq 'i386';
return "https://github.com/skaji/relocatable-perl/releases/download/$version/perl-$os-$arch.tar.gz";
}
return undef;
}
1;
|
