bin/smokehistory.pl

   1 #!/usr/bin/perl
   2
   3 # use 5.010;
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9
  10
  11 =head1 SYNOPSIS
  12
  13
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  22
  23 =item B<--cleanup!>
  24
  25 Be prepared for interactivity without an end. Nothing will be cleaned
  26 up without asking. See also --interative.
  27
  28 =item B<--dir=s>
  29
  30 defaults to C</home/sand/var/ctr/done/archive/>
  31
  32 =item B<--filter=s>
  33
  34 Only show reports for this distro. Exact distroname required
  35 (like C<Imager-Graph-0.09>). E.g.:
  36
  37   smokehistory.pl --numversions=1 --verbose --filter Test-Simple-1.301001026
  38
  39 =item B<--help|h!>
  40
  41 This help
  42
  43 =item B<--interactive|i!>
  44
  45 Defaults to true. If set to false (--nointeractive or --noi), you can
  46 remove hundreds of thousands of file without being asked a single
  47 question.
  48
  49 =item B<--delete-max=i>
  50
  51 Maximum number of files we want to see removed
  52
  53 =item B<--mixedtoyaml=s>
  54
  55 Writes a yaml file containing distros and reports where the reports
  56 are mixed. That's because the next step will have to parse the reports
  57 and may need a lot more focus and attention, so it makes sense to get
  58 that stuff separated out.
  59
  60 =item B<--numversions=i>
  61
  62 Defaults to 2 which means look at the two most recent versions for
  63 whatever we're doing. Everything older is discarded considered
  64 outdated.
  65
  66 =item B<--skipna!>
  67
  68 Skip both NA and unknown reports.
  69
  70 =item B<--verbose!>
  71
  72 write one line per report found
  73
  74 =back
  75
  76 =head1 DESCRIPTION
  77
  78 Walk through all reports we have generated and makes simple
  79 statistics. Or remove old reports (with --cleanup) for the distros
  80 that have got newer releases.
  81
  82 The initial version was only for cleanup and we called it like
  83
  84   on k85:
  85   sudo -u sand /path/to/perl bin/smokehistory.pl --numversions=3 --cleanup --noi
  86
  87 because we wanted to keep 3 versions and delete the older stuff and
  88 sudo was needed because the files belong to sand.
  89
  90 The second usage was for finding BBC candidates. For that we wrote
  91 smokehistoryfocus and combined
  92
  93   perl bin/smokehistory.pl --numversions=1 --mixedtoyaml=bin/smokehistory.pl.yml --skipna
  94
  95 with
  96
  97   perl bin/smokehistoryfocus.pl --bbc --skipanno --minperl 5.015004
  98
  99 numversions=1 drops all distros which are not the most recent release.
 100
 101 skipna only takes reports that are either pass or fail.
 102
 103 mixedtoyaml write those to a yaml file that promise some sort of mix
 104 in the results
 105
 106 bbc picks those that had 100% OK in a previous period and went to less.
 107
 108 skipanno ignores the stuff we have in annotate.txt
 109
 110 =head1 BUGS
 111
 112 linux hardcoded. If this shall be shared with non-linux results, reconsider.
 113
 114 =head1 SEE ALSO
 115
 116 smokehistoryfocus.pl
 117
 118 =cut
 119
 120
 121 use FindBin;
 122 use lib "$FindBin::Bin/../lib";
 123 BEGIN {
 124     push @INC, qw(       );
 125 }
 126
 127 use Dumpvalue;
 128 use File::Basename qw(dirname);
 129 use File::Path qw(mkpath);
 130 use File::Spec;
 131 use File::Temp;
 132 use Getopt::Long;
 133 use Pod::Usage;
 134 use Hash::Util qw(lock_keys);
 135 use List::MoreUtils qw(uniq);
 136 use List::Util qw(first);
 137 use Term::Prompt qw(prompt);
 138 use Text::Format;
 139 use YAML::Syck;
 140 use version;
 141
 142 our %Opt;
 143 lock_keys %Opt, map { /([^=!\|]+)/ } @opt;
 144 GetOptions(\%Opt,
 145            @opt,
 146           ) or pod2usage(1);
 147 if ($Opt{help}) {
 148     pod2usage(0);
 149 }
 150 $Opt{dir} ||= "/home/sand/var/ctr/done/archive";
 151 $Opt{interactive} = 1 unless defined $Opt{interactive};
 152 $Opt{numversions} ||= 2;
 153
 154 opendir my $dh, $Opt{dir} or die;
 155 my %S; # for the summary at the end
 156 my $Y; # for the yaml option
 157 my $tf = Text::Format->new(firstIndent=>0);
 158 my $total_deleted = 0;
 159 $|=1;
 160 LETTERDIR: for my $dirent (sort readdir $dh) { # A B C
 161     next LETTERDIR unless $dirent =~ /^[A-Za-z]$/;
 162     next LETTERDIR if $Opt{filter} && substr($Opt{filter},0,1) ne $dirent;
 163     opendir my $dh2, "$Opt{dir}/$dirent" or die;
 164  DISTRO: for my $dirent2 (readdir $dh2) { # FvwmPiazza CGI LWP-UserAgent-WithCache
 165         next DISTRO if $dirent2 =~ /^\.\.?$/;
 166         next DISTRO if $Opt{filter} && substr($Opt{filter},0,length($dirent2)) ne $dirent2;
 167         # we get A-B here even if we asked for A-B-C-42
 168         my $distro = $dirent2;
 169         my $cldir = "$Opt{dir}/$dirent/$dirent2/";
 170         opendir my $dh3, "$Opt{dir}/$dirent/$dirent2" or die;
 171         my %vdistro;
 172         my %result;
 173         my %report;
 174     REPORT: for my $dirent3 (readdir $dh3) { # pass.FvwmPiazza-0.2002.x86_64-linux-thread-multi-ld.2.6.32-5-xen-amd64.1300583966.24270.rpt
 175             next REPORT if $dirent3 =~ /^\.\.?$/;
 176             next REPORT unless $dirent3 =~ /\.rpt$/;
 177             my($result,$vdistro,$archname,$osversion,$time) =
 178                 $dirent3 =~ m{(\w+)\.                 # pass
 179                               (\S+)\.                 # Dist-Zilla-4.300039
 180                               ([^\.]+(?:linux|freebsd)[^\.]*)\.
 181                                                       # i686-linux-thread-multi-64int-ld
 182                               (\d\S+)\.               # 3.10-3-amd64
 183                               (\d+\.\d+)              # 1379556685.18399
 184                               \.rpt$
 185                          }x;
 186             die "could not parse '$dirent3' from directory '$dirent2' into its constituents" unless $vdistro;
 187             # warn "vdistro[$vdistro]";
 188             next REPORT if $Opt{filter} && $Opt{filter} ne $vdistro;
 189             if ($Opt{skipna} && $result =~ /(unknown|na)/) {
 190                 next REPORT;
 191             }
 192             if ($Opt{verbose}) {
 193                 require POSIX;
 194                 my($ts) = POSIX::strftime("%FT%T", localtime $time);
 195                 my $file = "$Opt{dir}/$dirent/$dirent2/$dirent3";
 196                 open my $fh, $file or die;
 197                 my($perl,$host);
 198                 while (<$fh>) {
 199                     my $X;
 200                     if (/^\s+\$\^X\s*=\s*(.+)/){
 201                         $X = $1;
 202                     } elsif (/config_args=.*-Dprefix=(\S+)/) {
 203                         # config_args='-Dprefix=/home/src/perl/repoperls/installed-perls/perl/v5.17.4-160-g599f1ac/a2da -Dmyhostname=k83 -Dinstallusrbinperl=n -Uversiononly -Dusedevel -des -Ui_db -Duseithreads -Duselongdouble -DDEBUGGING=-g'
 204                         $X = $1;
 205                     }
 206                     if ($X and $X =~ m{installed-perls/(perl|host/[^/]+)/(.+)}) {
 207                         $host = $1;
 208                         $perl = $2;
 209                         $perl =~ s|/bin/perl||;
 210                         if ($host eq "perl") {
 211                             $host = "";
 212                         } else {
 213                             $host =~ s|host/||;
 214                         }
 215                         last;
 216                     }
 217                 }
 218                 unless (defined $perl) {
 219                     $perl = "<undef>";
 220                     warn sprintf "Found no perl in %s\n", $file;
 221                 }
 222                 printf "%-6s %s %s%s\n", $result, $ts, $perl, $host ? " ($host)" : "";
 223             }
 224             my $r = $report{$vdistro} ||= [];
 225             push @$r, $dirent3;
 226             $vdistro{$vdistro} = 1;
 227             $result{$vdistro}{$result}++;
 228             $S{results}++;
 229         }
 230         my @vdistro = keys %vdistro;
 231         my %type;
 232     VDISTRO: for my $vdistro (@vdistro) {
 233             my $type;
 234             my @results = keys %{$result{$vdistro}};
 235             if (1 == @results) {
 236                 if (1 == @vdistro) {
 237                     # only one release tested, always same result
 238                     $S{one_release_boring}++;
 239                     next DISTRO unless $Opt{verbose};
 240                 }
 241                 $type = $results[0];
 242             } else {
 243                 $type = "mix";
 244             }
 245             $type{$vdistro} = $type;
 246         }
 247         my %version;
 248         for my $vdistro (keys %type) {
 249             my($distro,$version,$mod) = $vdistro =~ /(\S+)-(v?\d+(?:[\.\d]*[^-]*))(-(?:TRIAL|withoutworldwriteables|fix))?$/;
 250             unless (defined $version) {
 251                 # Angel102
 252                 ($distro,$version) = $vdistro =~ /(\D+)(\d+)/;
 253             }
 254             unless (defined $version){
 255                 die "could not parse version from $vdistro";
 256             }
 257             $version=~s/[^\d\.]+$//;
 258             1 while $version=~s/([\d\.])[^\d\.]+.*/$1/;
 259             $version=~s/\.$//;
 260             # print "DEBUG: parse version[$version] of distro[$distro](vdistro[$vdistro])\n";
 261             my $numversion = eval {version->new($version)->numify};
 262             if (not defined $numversion) {
 263                 die "ERROR: Could not parse version[$version] of distro[$distro](vdistro[$vdistro]): $@";
 264             } elsif ($@) {
 265                 die "Panic: we have a \$\@[$@] but a numversion[$numversion] too";
 266             }
 267             #if ($numversion==1) {
 268             #    warn "numversion[$numversion] version[$version] vdistro[$vdistro]";
 269             #    $DB::single=1;
 270             #}
 271             $version{$vdistro} = $numversion;
 272         }
 273         #$DB::single = $distro eq "savelogs";
 274         my @vdistros_sorted_by_version = sort { $version{$b} <=> $version{$a} } keys %type;
 275         while (@vdistros_sorted_by_version > $Opt{numversions}) {
 276             if ($Opt{cleanup}) {
 277                 my @cldirent = @{$report{$vdistros_sorted_by_version[-1]}};
 278                 my $report = sprintf
 279                     ("==> Having reports from
 280  %d versions of
 281  %s in directory
 282  %s. The oldest of those,
 283  %s, has
 284  %d reports. We could remove:\n\n",
 285                      scalar @vdistros_sorted_by_version,
 286                      $distro,
 287                      $cldir,
 288                      $vdistros_sorted_by_version[-1],
 289                      scalar @cldirent,
 290                     );
 291                 print $tf->format($report);
 292                 warn map { "$_\n" } @cldirent;
 293                 $S{could_delete_reports} += @{$report{$vdistros_sorted_by_version[-1]}};
 294                 my $answer;
 295                 if ($Opt{interactive}) {
 296                     $answer = lc prompt "x", "Shall I delete? (y/n/q)", "", "y";
 297                 } else {
 298                     $answer = 'y';
 299                 }
 300                 if ($answer eq "q") {
 301                     last LETTERDIR;
 302                 } elsif ($answer eq "n") {
 303                 } elsif ($answer eq "y") {
 304                     if ($Opt{"delete-max"}) {
 305                         my $will_delete = @cldirent;
 306                         if ($total_deleted + $will_delete > $Opt{"delete-max"}) {
 307                             die "Delete operation would delete $will_delete files, stopping now due delete-max option. Already deleted: $total_deleted\n";
 308                         }
 309                     }
 310                     my $deleted = unlink map { "$cldir$_" } @cldirent or die "Could not unlink: $!";
 311                     $total_deleted += $deleted;
 312                     if ($Opt{interactive}) {
 313                         warn "Deleted $deleted reports. Press ENTER to continue\n";
 314                         <>;
 315                     }
 316                 }
 317             }
 318             my $pop = pop @vdistros_sorted_by_version;
 319             delete $type{$pop};
 320             $S{outdated}++;
 321         }
 322         my @types = uniq values %type;
 323         if (! first { $_ eq "mix" } @types){
 324             $S{n_releases_boring}++;
 325             next DISTRO unless $Opt{verbose};
 326         }
 327         for my $vdistro (sort keys %type) {
 328             my $type = $type{$vdistro};
 329             printf "%-50s %s\n", $vdistro, $type;
 330             if ($Opt{mixedtoyaml}) {
 331                 $Y->{$vdistro} = [map { "$cldir$_" } @{$report{$vdistro}}];
 332             }
 333             $S{wrote}++;
 334         }
 335     }
 336 }
 337 warn YAML::Syck::Dump \%S;
 338 if (my $file = $Opt{mixedtoyaml}) {
 339     YAML::Syck::DumpFile $file, $Y;
 340     warn "Wrote yaml to '$file'\n";
 341 }
 342
 343 # Local Variables:
 344 # mode: cperl
 345 # cperl-indent-level: 4
 346 # End: