bin/compare-megalogdirs.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  compare-megalogdirs.pl dir-or-logfile dir-or-logfile
  14  compare-megalogdirs.pl glob
  15
  16 =head1 OPTIONS
  17
  18 =over 8
  19
  20 =cut
  21
  22 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  23
  24 =item B<--annofile=s>
  25
  26 Path to annofile.
  27
  28 =item B<--bbc!>
  29
  30 Only show OK => NOT OK
  31
  32 =item B<--debugcolorout!>
  33
  34 if colorout-to-dir prg is to be run, call it with -d
  35
  36 =item B<--help|h!>
  37
  38 This help
  39
  40 =item B<--skipanno!>
  41
  42 Skip things that have a line in annotated.txt
  43
  44 =item B<--times!>
  45
  46 Compare runtimes, not status. Limit yourself to OK=>OK.
  47
  48 =back
  49
  50 =head1 DESCRIPTION
  51
  52 Reads two megalog directories and outputs modules with differing
  53 status. Instead of directory names also the lognames may be given, in
  54 this case the directories will be created if missing.
  55
  56 -or-
  57
  58 if the --times option is given, outputs times only on OK=>OK pairs.
  59
  60 =head1 SEE ALSO
  61
  62 colorout-to-dir-3.pl
  63
  64 =cut
  65
  66
  67 use FindBin;
  68 use lib "$FindBin::Bin/../lib";
  69 BEGIN {
  70     push @INC, qw(       );
  71 }
  72
  73 use CPAN::DistnameInfo;
  74 use Dumpvalue;
  75 use File::Basename qw(basename dirname);
  76 use File::Path qw(mkpath);
  77 use File::Spec;
  78 use File::Temp;
  79 use Getopt::Long;
  80 use Hash::Util qw(lock_keys);
  81 use List::MoreUtils qw(uniq);
  82 use Pod::Usage;
  83 use YAML::Syck ();
  84
  85 our %Opt;
  86 lock_keys %Opt, map { /([^\=\!\|]+)/ } @opt;
  87 GetOptions(\%Opt,
  88            @opt,
  89           ) or pod2usage(1);
  90 if ($Opt{help}) {
  91     pod2usage(1);
  92 }
  93
  94 $Opt{annofile} ||= "/home/k/sources/CPAN/andk-cpan-tools/annotate.txt";
  95
  96 my(%anno, %olderanno);
  97 if ($Opt{skipanno}) {
  98     my $annofile = $Opt{annofile};
  99     open my $fh, $annofile or die "could not open '$annofile': $!";
 100     while (<$fh>) {
 101         my($dist,$anno) = /^(\S+)\s+(.*)/;
 102         $anno{$dist} = $anno;
 103         $dist =~ s/_//g;
 104         $anno{$dist} = $anno; # prevent DCONWAY/List-Maker-0.003_000.tar.gz to appear
 105         my $stem = $dist; # should we use Distnameinfo?
 106         $stem =~ s/-\d[\d\._]*(-TRIAL)?//;
 107         $olderanno{$stem} = $dist;
 108     }
 109 }
 110
 111 my($ldir,$rdir,@rest) = @ARGV;
 112 my($lperlref,$rperlref)=(\my $lperl,\my $rperl);
 113 if (@rest) {
 114     die "Got more than two arguments: rejecting @rest";
 115 }
 116 if ($ldir && !$rdir && $ldir =~ /\{/) {
 117     my($gldir,$grdir,@grest) = glob $ldir;
 118     if (@grest) {
 119         die "Your glob '$ldir' matches more than two: $gldir $grdir; rejecting: @grest";
 120     }
 121     unless ($gldir){
 122         die "Your glob '$ldir' did not match anything, giving up";
 123     }
 124     unless ($grdir){
 125         die "Your glob '$ldir' matched only one thing: $gldir, giving up";
 126     }
 127     $ldir = $gldir;
 128     $rdir = $grdir;
 129 }
 130 unless (defined $rdir){
 131     warn "Usage error: Missing second argument\n";
 132     pod2usage(1);
 133 }
 134 for ($ldir,$rdir) {
 135     my $log = $_;
 136     if (s/\.(?:log)?$/.d/) { # allow both xxx.log and xxx. instead of xxx.d
 137         my($dir) = $_;
 138         if (-d $dir) {
 139             warn "directory '$dir' exists already, assuming I shall leave it as it is";
 140         } else {
 141             my @system = $^X;
 142             if ($Opt{debugcolorout}) {
 143                 push @system, "-d";
 144             }
 145             my($name,$path,$suffix) = File::Basename::fileparse($0,".pl");
 146             $path .= "colorout-to-dir-3.pl";
 147             push @system, $path, "--html", $log;
 148             warn "running system[@system]";
 149             0==system @system or die "problem running '@system'";
 150         }
 151     }
 152 }
 153 my $left  = {};
 154 my $right = {};
 155 my $canon = {};
 156 my $base = {};
 157 my $superview = {};
 158 for my $tuple (["left",$left,$ldir,$lperlref],
 159                ["right",$right,$rdir,$rperlref],
 160               ) {
 161     my($side,$snap,$dir,$tperlref) = @$tuple;
 162     $superview->{"$side-dir"} = $dir;
 163     opendir my $dh, $dir or die "Could not opendir '$dir': $!";
 164     my $in_list = 0;
 165     my $count = 0;
 166   DIRENT: for my $dirent (readdir $dh) {
 167         next DIRENT unless my($author,$distpath) = $dirent =~ /(.+?)!(.+)\.html$/;
 168         $count++;
 169         $distpath =~ s:!:/:g;
 170         my $dist = basename($distpath);
 171         if ($Opt{skipanno} and $anno{$dist}) {
 172             next DIRENT;
 173         }
 174         open my $fh, "$dir/$dirent" or die "could not open $dir/$dirent: $!";
 175         my $status;
 176         my $canon1;
 177         my $cputime;
 178     LINE: while (<$fh>) {
 179             if (m|<h2>Status:\s+(.+)</h2>$|){$status = $1;}
 180             elsif (m|<h2>Distro:\s+(.+)</h2>$|){$canon1 = $1;}
 181             elsif (!$$tperlref and m|<h2>Perl:\s+.+?/installed-perls/(.+)</h2>$|){$$tperlref ||= $1;}
 182             elsif (m|=\s+(\S+)\s+CPU\s*\)$|){$cputime = $1;}
 183             if ($Opt{times}) {
 184                 # 1 wallclock secs ( 0.02 usr  0.00 sys +  0.22 cusr  0.00 csys =  0.24 CPU)
 185                 # =  0.29 CPU)
 186                 last LINE if $cputime;
 187             } else {
 188                 last LINE if $status && $canon1;
 189             }
 190         }
 191         close $fh;
 192         $superview->{"$side-$status"}++;
 193         next DIRENT if $status eq "RESIDUUM";
 194         if ($distpath =~ m|[=']|) {
 195             warn "Skipping suspicious file '$distpath' in '$dir'";
 196             next DIRENT;
 197         }
 198         for ("$author/$distpath") {
 199             $base->{$_} = $dist;
 200             $canon->{$_} = $canon1;
 201             if ($Opt{times}) {
 202                 if ($cputime) {
 203                     $snap->{$_} = "$status $cputime";
 204                 }
 205             } else {
 206                 $snap->{$_} = $status;
 207             }
 208         }
 209     }
 210     $superview->{"$side-perl"} = $$tperlref;
 211     if ($count == 0) {
 212         die "Alert: NO html files found in '$dir'";
 213     }
 214 }
 215 my(@miss_left,@miss_right,@diff,@bothok);
 216 my $c1 = 0;
 217 DISTRO: for my $m (uniq keys %$left, keys %$right) { # $m = "RWSTAUNER/File-Spec-Native-1.003"
 218     $c1 = length $m if length $m > $c1;
 219     if ($Opt{times}) {
 220         next DISTRO unless $left->{$m} && $left->{$m} =~ /^OK/ && $right->{$m} && $right->{$m} =~ /^OK/;
 221         push @bothok, [$m, $left->{$m}, $right->{$m}];
 222     } else {
 223         if (! exists $right->{$m}) {
 224             push @miss_right, [$m, $left->{$m}];
 225             next DISTRO;
 226         } elsif (! exists $left->{$m}) {
 227             push @miss_left, [$m, $right->{$m}];
 228             next DISTRO;
 229         }
 230         next DISTRO if $left->{$m} eq $right->{$m};
 231         push @diff, [$m, $left->{$m}, $right->{$m}];
 232     }
 233 }
 234 {
 235     # in miss_left and miss_right we now have common distributions that
 236     # got upgraded. We postprocess them now because they should be
 237     # presented differently.
 238     my %dist;
 239     for my $tutu ([left=>\@miss_left],[right=>\@miss_right]) {
 240         my($leftright,$miss) = @$tutu;
 241         for (my $i = $#$miss;$i>-1;$i--) {
 242             my $tuple = $miss->[$i];
 243             my $path = sprintf "authors/id/%s/%s/%s.tar.gz", substr($tuple->[0],0,1), substr($tuple->[0],0,2), $tuple->[0];
 244             my $d = CPAN::DistnameInfo->new($path);
 245             my $dcpanid = $d->cpanid or warn "missing id on path[$path]";
 246             my $ddist = $d->dist or warn "missing dist on path[$path]";
 247             my $dist = sprintf "%s/%s", $dcpanid, $ddist;
 248             $dist{$dist}{$leftright}{arr} = splice @$miss, $i, 1;
 249             $dist{$dist}{$leftright}{version} = $d->version;
 250             $dist{$dist}{was}{$leftright}{distv} = sprintf("%s/%s", $dcpanid, $d->distvname);
 251         }
 252     }
 253     for my $dist (keys %dist) {
 254         no warnings 'uninitialized';
 255         push @diff, [exists $dist{$dist}{was}{left} ? $dist{$dist}{was}{left}{distv} : $dist,
 256                      # miss right = have left:
 257                      "$dist{$dist}{right}{version} $dist{$dist}{right}{arr}[1]",
 258                      "$dist{$dist}{left}{version} $dist{$dist}{left}{arr}[1]",
 259                      $dist{$dist},
 260                     ];
 261     }
 262 }
 263 my $c2 = 15;
 264 unless ($Opt{bbc}) {
 265     #warn "Missing right\n";
 266     for my $tuple (sort {$a->[0] cmp $b->[0]} @miss_right) {
 267         printf "%${c1}s %${c2}s =>\n", @$tuple;
 268     }
 269     #warn "Missing left\n";
 270     for my $tuple (sort {$a->[0] cmp $b->[0]} @miss_left) {
 271         #while (length $tuple->[0] > $c1) {
 272         #    (my $trim,$tuple->[0]) = unpack("a" . $c1 . "a*", $tuple->[0]);
 273         #    print "$trim\n";
 274         #}
 275         printf "%${c1}s %${c2}s => %-${c2}s\n", $tuple->[0], "", $tuple->[1];
 276     }
 277 }
 278 #warn "Diffing left right\n";
 279 print YAML::Syck::Dump
 280     ({
 281       ldir => $ldir,
 282       lperl => $lperl,
 283       rdir => $rdir,
 284       rperl => $rperl,
 285      });
 286 my $D = [];
 287 for my $tuple (sort {lc($base->{$a->[0]}||"") cmp lc($base->{$b->[0]}||"")} @diff) {
 288     my $matrx = "";
 289     my $lpath = "";
 290     my $distv = $base->{$tuple->[0]};
 291     if ($tuple->[1] =~ /^(OK|.*[^T] OK)$/ and $tuple->[2] =~ /NOT OK$/) {
 292         my $bang = $tuple->[0];
 293         $bang =~ s{/}{!}g;
 294         $matrx = sprintf "http://matrix.cpantesters.org/?dist=%s", $distv;
 295         $lpath = sprintf "%s/%s.html", $rdir, $bang;
 296     }
 297     if ($Opt{bbc} && $matrx) {
 298         my $path = sprintf "authors/id/%s/%s/%s.tar.gz", substr($tuple->[0],0,1), substr($tuple->[0],0,2), $tuple->[0];
 299         my $d = CPAN::DistnameInfo->new($path);
 300         my $stem = $d->dist;
 301         my $audis;
 302         if (@$tuple >= 4) {
 303             $audis = sprintf "%s <= %s", $tuple->[0], $tuple->[3]{right}{arr}[0];
 304         } else {
 305             $audis = $tuple->[0];
 306         }
 307         my $dump = {
 308                     audis => $audis,
 309                     canon => $canon->{$tuple->[0]},
 310                     distv => $distv,
 311                     lpath => $lpath,
 312                     matrx => $matrx,
 313                     stem  => $stem,
 314                    };
 315         if ($Opt{skipanno}) {
 316             if (my $olderanno = $olderanno{$stem}) {
 317                 $dump->{olderanno} = $olderanno;
 318             }
 319         }
 320         push @$D, $dump;
 321         print YAML::Syck::Dump($dump);
 322     } elsif (!$Opt{bbc}) {
 323         printf "%${c1}s %${c2}s => %-${c2}s%s\n", @$tuple, $matrx;
 324     }
 325 }
 326 if ($Opt{bbc}) {
 327     print YAML::Syck::Dump({
 328         count=>scalar(@$D),
 329         stems=>join(",",map{$D->[$_]{stem}}0..$#$D),
 330     });
 331 }
 332 for my $tuple (sort {lc($base->{$a->[0]}||"") cmp lc($base->{$b->[0]}||"")} @bothok) {
 333         printf "BOTHOK: %${c1}s %${c2}s => %-${c2}s\n", @$tuple;
 334 }
 335 for my $some_ok ("OK", "NOT OK") {
 336     for my $lr (qw(left right)) {
 337         $superview->{"$lr-either-ok-or-not-ok"} += $superview->{"$lr-$some_ok"};
 338     }
 339 }
 340 $superview->{summary} = sprintf "l/r => %.4f, r/l => %.4f",
 341     $superview->{"left-either-ok-or-not-ok"}/$superview->{"right-either-ok-or-not-ok"},
 342     $superview->{"right-either-ok-or-not-ok"}/$superview->{"left-either-ok-or-not-ok"};
 343 print YAML::Syck::Dump($superview);
 344 # Local Variables:
 345 # mode: cperl
 346 # cperl-indent-level: 4
 347 # End: