diff --git a/shrink.pl b/shrink.pl index deba89b..8778c65 100755 --- a/shrink.pl +++ b/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();