-
Notifications
You must be signed in to change notification settings - Fork 0
/
rotate.pl
114 lines (100 loc) · 3.21 KB
/
rotate.pl
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
use strict;
use warnings;
use File::Spec;
use IPC::Cmd qw[can_run];
use Capture::Tiny qw[capture_merged];
use Perl::Version;
use FindBin qw[$Bin];
use Getopt::Long;
use List::UtilsBy qw[zip_by];
use Cwd;
my $reverse;
my $weave;
my $random;
GetOptions( 'reverse', \$reverse, 'weave', \$weave, 'random', \$random );
die unless @ARGV;
my $zaptmp = File::Spec->catfile( $Bin, 'zaptmp.pl' );
my $zapfake = File::Spec->catfile( $Bin, 'zapfake.pl' );
my $zapjail = File::Spec->catfile( $Bin, 'zapjail.pl' );
my $minismokebox = File::Spec->catfile($Config::Config{installsitescript},'minismokebox');
die "No 'minismokebox' found\n" unless $minismokebox;
my $shell;
$shell = can_run('bash');
$shell = can_run('sh') unless $shell;
$shell = '/bin/sh' unless $shell;
open my $script, '>', 'rotate.sh' or die "$!\n";
print $script "#!$shell", "\n";
print $script "while true;\ndo\n";
my @order;
my %things;
foreach my $arg ( @ARGV ) {
push @order, $arg;
my $path = Cwd::realpath($arg);
next unless -d $path;
my $confroot = File::Spec->catdir( $path, 'conf' );
next unless -d $confroot;
my @perls;
opendir my $dir, $path or die "$!\n";
while (my $item = readdir($dir)) {
next unless $item =~ /^perl-/;
push @perls, $item;
}
closedir $dir;
next unless @perls;
foreach my $perl ( sort _version_sort @perls ) {
my $conf = File::Spec->catdir( $confroot, $perl );
next unless -d $conf;
my $perlexe = File::Spec->catfile($path,$perl,'bin','perl');
unless ( -e $perlexe ) {
# hmmm no perl there. Let's see if it is a dev release
my @possibles = glob("${perlexe}5*");
die "No perl executable found at '$path'\n" unless @possibles;
$perlexe = shift @possibles;
}
my $output = capture_merged { system($perlexe,'-e','printf "%vd", $^V;'); };
chomp $output;
my $cpanp = File::Spec->catfile($path,$perl,'bin','cpanp' . ( $perlexe =~ /\Q$output\E$/ ? $output : '' ) );
my $yactool = File::Spec->catfile($path,$perl,'bin','yactool');
push @{ $things{ $arg } },
{
perlexe => $perlexe,
yactool => $yactool,
cpanp => $cpanp,
conf => $conf,
};
}
}
my @data;
if ( $weave ) {
@data = zip_by { @_ } @things{ @order };
}
else {
@data = @things{ @order };
}
foreach my $item ( @data ) {
my ($conf,$perlexe,$cpanp,$yactool) = @{$item}{qw(conf perlexe cpanp yactool)};
next unless $yactool && -e $yactool; # No yactool then pointless
print $script "export PERL5_YACSMOKE_BASE=$conf\n";
print $script "$yactool --flush\n";
print $script "$cpanp -x --update_source\n";
print $script "$minismokebox --perl $perlexe";
print $script " --recent --random" if $random;
print $script "\n";
print $script "$yactool --flush\n";
print $script "$^X $zaptmp\n";
print $script "$^X $zapfake\n";
print $script "$^X $zapjail\n";
}
print $script "ipcrm -m all\nipcrm -s all\n" if $^O eq 'netbsd';
print $script "done\n";
close $script;
chmod 0755, 'rotate.sh' or die "$!\n";
exit 0;
sub _version_sort {
if ( $reverse ) {
Perl::Version->new( ( split /-/, $b )[1] )->numify <=> Perl::Version->new( ( split /-/, $a )[1] )->numify;
}
else {
Perl::Version->new( ( split /-/, $a )[1] )->numify <=> Perl::Version->new( ( split /-/, $b )[1] )->numify;
}
}