allow custom commands with arbitrary number of Packages/Sources files
This commit is contained in:
parent
197995a019
commit
c2958fa501
1 changed files with 148 additions and 56 deletions
204
shrink.pl
204
shrink.pl
|
|
@ -29,11 +29,16 @@ use Dpkg::Index;
|
|||
use List::Util 'shuffle';
|
||||
|
||||
sub check {
|
||||
system 'dose-builddebcheck', '--failures', '--explain', '--quiet', '--deb-native-arch=kfreebsd-i386', 'tmp', 'wanna-build-interesting-sources-sid.kfreebsd-i386';
|
||||
my $wantedexit = shift;
|
||||
print "running: ";
|
||||
print join " ", @_;
|
||||
print "\n";
|
||||
system @_;
|
||||
my $exit = $? >> 8;
|
||||
if ($exit == 64) {
|
||||
if ($exit == $wantedexit) {
|
||||
return 1;
|
||||
} else {
|
||||
print "got exit $exit but wanted exit $wantedexit\n";
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
|
@ -41,8 +46,10 @@ sub check {
|
|||
sub write_enabled_pkgs {
|
||||
my $index = shift;
|
||||
my $enabled = shift;
|
||||
my $fname = shift;
|
||||
print "writing to $fname\n";
|
||||
# write out all the still enabled packages
|
||||
open(my $fh, '>', 'tmp');
|
||||
open(my $fh, '>', $fname);
|
||||
foreach my $k ($index->get_keys()) {
|
||||
if (!$enabled->{$k}) {
|
||||
next;
|
||||
|
|
@ -56,8 +63,11 @@ sub randomize_pkgs {
|
|||
my $index = shift;
|
||||
my $enabled = shift;
|
||||
my $id_to_key = shift;
|
||||
my $tmpname = shift;
|
||||
my $wantedexit = shift;
|
||||
my @checkcmd = @_;
|
||||
# randomly delete 0.5% of the packages until we failed to produce the
|
||||
# expected result 20 consecutive times
|
||||
# expected result as many times as 1% of the package are.
|
||||
my $num_failures = 0;
|
||||
while (1) {
|
||||
# fill an array with the remaining enabled indices
|
||||
|
|
@ -79,8 +89,8 @@ sub randomize_pkgs {
|
|||
for my $i (@to_disable) {
|
||||
$enabled->{$id_to_key->{$i}} = 0;
|
||||
}
|
||||
write_enabled_pkgs($index, $enabled);
|
||||
if (check()) {
|
||||
write_enabled_pkgs($index, $enabled, $tmpname);
|
||||
if (check($wantedexit, @checkcmd)) {
|
||||
# the error we want to see is still there so we keep these keys
|
||||
# disabled and reset the number of failures
|
||||
$num_failures = 0;
|
||||
|
|
@ -112,6 +122,9 @@ sub iterate_pkgs {
|
|||
my $index = shift;
|
||||
my $enabled = shift;
|
||||
my $id_to_key = shift;
|
||||
my $tmpname = shift;
|
||||
my $wantedexit = shift;
|
||||
my @checkcmd = @_;
|
||||
# we extract the array of enabled indices for better progress reporting
|
||||
# later on
|
||||
my $numpkgs = scalar keys %{$enabled};
|
||||
|
|
@ -134,8 +147,8 @@ sub iterate_pkgs {
|
|||
$i += 1;
|
||||
# disable the current key
|
||||
$enabled->{$key} = 0;
|
||||
write_enabled_pkgs($index, $enabled);
|
||||
if (check()) {
|
||||
write_enabled_pkgs($index, $enabled, $tmpname);
|
||||
if (check($wantedexit, @checkcmd)) {
|
||||
# the error we want to see is still there so we keep this key disabled
|
||||
} else {
|
||||
# the error vanished
|
||||
|
|
@ -150,6 +163,9 @@ sub delete_field {
|
|||
my $enabled = shift;
|
||||
my $id_to_key = shift;
|
||||
my $field = shift;
|
||||
my $tmpname = shift;
|
||||
my $wantedexit = shift;
|
||||
my @checkcmd = @_;
|
||||
# we extract the array of enabled indices for better progress reporting
|
||||
# later on
|
||||
my $numpkgs = scalar keys %{$enabled};
|
||||
|
|
@ -178,8 +194,8 @@ sub delete_field {
|
|||
my $fieldvalue = $pkg->{$field};
|
||||
# disable the current key
|
||||
delete $pkg->{$field};
|
||||
write_enabled_pkgs($index, $enabled);
|
||||
if (check()) {
|
||||
write_enabled_pkgs($index, $enabled, $tmpname);
|
||||
if (check($wantedexit, @checkcmd)) {
|
||||
# the error we want to see is still there so we keep this field deleted
|
||||
} else {
|
||||
# the error vanished
|
||||
|
|
@ -190,59 +206,135 @@ sub delete_field {
|
|||
}
|
||||
|
||||
sub main {
|
||||
my $desc = $ARGV[0];
|
||||
if (not defined($desc)) {
|
||||
die "need a Packages file";
|
||||
my @srcbinlisttype = ();
|
||||
|
||||
# first argument is the desired exit code
|
||||
my $wantedexit = shift @ARGV;
|
||||
|
||||
# the following argument are paths to Packages/Sources files
|
||||
# to find out how many of those we expect, we scan the rest of ARGV for
|
||||
# the placeholders
|
||||
foreach my $arg (@ARGV) {
|
||||
if ($arg eq '__src__') {
|
||||
push @srcbinlisttype, "src";
|
||||
}
|
||||
if ($arg eq '__bin__') {
|
||||
push @srcbinlisttype, "bin";
|
||||
}
|
||||
}
|
||||
|
||||
my $key_func = sub {
|
||||
return $_[0]->{Package} . ' ' . $_[0]->{Version} . ' ' . $_[0]->{Architecture};
|
||||
};
|
||||
|
||||
my $index = Dpkg::Index->new(get_key_func=>$key_func);
|
||||
|
||||
$index->load($desc);
|
||||
my %allowed_fields = (
|
||||
'Version' => 1,
|
||||
'Package' => 1,
|
||||
'Architecture' => 1,
|
||||
'Depends' => 1,
|
||||
# 'Multi-Arch' => 1, # not needed with only one architecture
|
||||
'Provides' => 1,
|
||||
'Breaks' => 1,
|
||||
'Conflicts' => 1,
|
||||
'Pre-Depends' => 1,
|
||||
# 'Essential' => 1, # probably not needed
|
||||
);
|
||||
|
||||
my %enabled = ();
|
||||
my %id_to_key = ();
|
||||
{
|
||||
my $i = 0;
|
||||
foreach my $key ($index->get_keys()) {
|
||||
$enabled{$key} = 1;
|
||||
$id_to_key{$i} = $key;
|
||||
# now we now which parts are the actual input file names
|
||||
my @srcbinlistcontent = splice @ARGV, 0, (scalar @srcbinlisttype);
|
||||
# the rest is the command to execute
|
||||
my @execcmd = @ARGV;
|
||||
my $i = 0;
|
||||
my @tmpfiles = ();
|
||||
foreach my $val (@execcmd) {
|
||||
if ($val eq '__src__') {
|
||||
$val = "src.$i.tmp";
|
||||
push @tmpfiles, $val;
|
||||
$i += 1;
|
||||
}
|
||||
if ($val eq '__bin__') {
|
||||
$val = "bin.$i.tmp";
|
||||
push @tmpfiles, $val;
|
||||
$i += 1;
|
||||
# delete unnecessary fields
|
||||
my $cdata = $index->get_by_key($key);
|
||||
foreach my $field (keys %{$cdata}) {
|
||||
if (! exists $allowed_fields{$field}) {
|
||||
delete $cdata->{$field};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
randomize_pkgs($index, \%enabled, \%id_to_key);
|
||||
iterate_pkgs($index, \%enabled, \%id_to_key);
|
||||
delete_field($index, \%enabled, \%id_to_key, 'Depends');
|
||||
delete_field($index, \%enabled, \%id_to_key, 'Pre-Depends');
|
||||
delete_field($index, \%enabled, \%id_to_key, 'Conflicts');
|
||||
delete_field($index, \%enabled, \%id_to_key, 'Breaks');
|
||||
delete_field($index, \%enabled, \%id_to_key, 'Provides');
|
||||
my @data = ();
|
||||
foreach( 0 .. $#srcbinlistcontent ) {
|
||||
my $f = $srcbinlistcontent[$_];
|
||||
my $t = $srcbinlisttype[$_];
|
||||
my $r = $tmpfiles[$_];
|
||||
|
||||
print "reading in $f\n";
|
||||
|
||||
my $key_func = sub {
|
||||
return $_[0]->{Package} . ' ' . $_[0]->{Version} . ' ' . $_[0]->{Architecture};
|
||||
};
|
||||
|
||||
my $index = Dpkg::Index->new(get_key_func=>$key_func);
|
||||
|
||||
$index->load($f);
|
||||
my %allowed_fields = (
|
||||
'Version' => 1,
|
||||
'Package' => 1,
|
||||
'Architecture' => 1,
|
||||
);
|
||||
if ($t eq "bin") {
|
||||
$allowed_fields{'Depends'} = 1;
|
||||
# 'Multi-Arch' => 1, # not needed with only one architecture
|
||||
$allowed_fields{'Provides'} = 1;
|
||||
$allowed_fields{'Breaks'} = 1;
|
||||
$allowed_fields{'Conflicts'} = 1;
|
||||
$allowed_fields{'Pre-Depends'} = 1;
|
||||
$allowed_fields{'Source'} = 1;
|
||||
$allowed_fields{'Essential'} = 1; # probably not needed
|
||||
} else {
|
||||
$allowed_fields{'Build-Depends'} = 1;
|
||||
$allowed_fields{'Build-Depends-Arch'} = 1;
|
||||
$allowed_fields{'Build-Depends-Indep'} = 1;
|
||||
$allowed_fields{'Build-Conflicts'} = 1;
|
||||
$allowed_fields{'Build-Conflicts-Arch'} = 1;
|
||||
$allowed_fields{'Build-Conflicts-Indep'} = 1;
|
||||
}
|
||||
|
||||
my %enabled = ();
|
||||
my %id_to_key = ();
|
||||
{
|
||||
my $i = 0;
|
||||
foreach my $key ($index->get_keys()) {
|
||||
$enabled{$key} = 1;
|
||||
$id_to_key{$i} = $key;
|
||||
$i += 1;
|
||||
# delete unnecessary fields
|
||||
my $cdata = $index->get_by_key($key);
|
||||
foreach my $field (keys %{$cdata}) {
|
||||
if (! exists $allowed_fields{$field}) {
|
||||
delete $cdata->{$field};
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
write_enabled_pkgs($index, \%enabled, $r);
|
||||
|
||||
push @data, [$r, $t, $index, \%enabled, \%id_to_key];
|
||||
}
|
||||
|
||||
foreach my $v (@data) {
|
||||
my ($tmpname, $t, $index, $enabled, $id_to_key) = @{$v};
|
||||
randomize_pkgs($index, $enabled, $id_to_key, $tmpname, $wantedexit, @execcmd);
|
||||
}
|
||||
foreach my $v (@data) {
|
||||
my ($tmpname, $t, $index, $enabled, $id_to_key) = @{$v};
|
||||
iterate_pkgs($index, $enabled, $id_to_key, $tmpname, $wantedexit, @execcmd);
|
||||
}
|
||||
|
||||
foreach my $v (@data) {
|
||||
my ($tmpname, $t, $index, $enabled, $id_to_key) = @{$v};
|
||||
if ($t eq "bin") {
|
||||
delete_field($index, $enabled, $id_to_key, 'Depends', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Pre-Depends', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Conflicts', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Breaks', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Provides', $tmpname, $wantedexit, @execcmd);
|
||||
} else {
|
||||
delete_field($index, $enabled, $id_to_key, 'Build-Depends', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Build-Depends-Indep', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Build-Depends-Arch', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Build-Conflicts', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Build-Conflicts-Indep', $tmpname, $wantedexit, @execcmd);
|
||||
delete_field($index, $enabled, $id_to_key, 'Build-Conflicts-Arch', $tmpname, $wantedexit, @execcmd);
|
||||
}
|
||||
}
|
||||
|
||||
# somehow, calling randomize_pkgs might remove build-essential
|
||||
#randomize_pkgs($index, \%enabled, \%id_to_key);
|
||||
iterate_pkgs($index, \%enabled, \%id_to_key);
|
||||
foreach my $v (@data) {
|
||||
my ($tmpname, $t, $index, $enabled, $id_to_key) = @{$v};
|
||||
iterate_pkgs($index, $enabled, $id_to_key, $tmpname, $wantedexit, @execcmd);
|
||||
}
|
||||
}
|
||||
|
||||
main();
|
||||
|
|
|
|||
Loading…
Reference in a new issue