bin/colorout-to-dir-3.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  colorout-to-dir-3.pl file
  14
  15  eg: perl ~k/sources/CPAN/andk-cpan-tools/bin/colorout-to-dir-3.pl --html megalog-2012-04-24T21:44:13.log
  16
  17 =head1 OPTIONS
  18
  19 =over 8
  20
  21 =cut
  22
  23 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  24
  25 =item B<--help|h!>
  26
  27 This help
  28
  29 =item B<--html!>
  30
  31 Do not produce XML but additional stuff so we get XHTML
  32
  33 =back
  34
  35 =head1 DESCRIPTION
  36
  37 ALERT: program does not work anymore. Bitrot. Missing comments in the
  38 code make it hard to understand why it worked. See
  39 /home/sand-legacy/andk-cpan-tools.localdisk-deprecated/logs/megainstall.20090215T0811.out
  40 for possibly the youngest left over megainstall file with accompanying
  41 directory of XML results.
  42
  43 The two versions colorout-to-dir.pl and colorout-to-dir-2.pl were
  44 written at the time of the megainstall target. This
  45 colorout-to-dir-3.pl is a reincarnation because our megalog files are
  46 nearly identical to the megainstall files. It now has a manpapage and
  47 we want to add options instead of writing more and more variations. We
  48 have turned on warnings because it was not really hard to do and maybe
  49 it helps us to understand better what we're doing.
  50
  51 The bad things that can happen:
  52
  53 (1) too many lines left over in residuum.yml. Why is there a
  54 SPURKIS!accessors-1.01.xml that does not start with 'Running
  55 install...'?
  56
  57 (2) two things in one: why is there so much about CSS-DOM and
  58 HTML-Encoding within SPROUT!HTML-DOM-0.053.html?
  59
  60 =head1 SEE ALSO
  61
  62 compare-megalogdirs.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 Dumpvalue;
  74 use File::Basename qw(dirname);
  75 use File::Path qw(mkpath);
  76 use File::Spec;
  77 use File::Temp;
  78 use Getopt::Long;
  79 use Hash::Util qw(lock_keys);
  80
  81 our %Opt;
  82 lock_keys %Opt, map { /([^=\|\!]+)/ } @opt;
  83 GetOptions(\%Opt,
  84            @opt,
  85           ) or pod2usage(1);
  86 if ($Opt{help}) {
  87     pod2usage(1);
  88 }
  89
  90 # translating
  91 #!/usr/bin/perl -0777 -nl
  92 my $parsefile = shift or pod2usage(1);
  93
  94 use Encode qw(decode);
  95 use List::MoreUtils qw(uniq);
  96 use Time::HiRes qw(sleep time);
  97 use YAML::Syck;
  98
  99 our $VERIFY_XML = 0;
 100 if ($VERIFY_XML) {
 101   require XML::LibXML;
 102   our $p = XML::LibXML->new;
 103 }
 104 $_ = do { open my $fh, $parsefile or die "Could not open '$parsefile': $!"; local $/; <$fh> };
 105 chomp;
 106 our $start = time;
 107 our($perl) = m!perl\|\-\>\s(/home\S+/installed-perls/(?:.*?)/bin/perl)\s!;
 108 unless ($perl) {
 109   die "ALERT: Could not find a valid path to a perl in '$parsefile', maybe remove this irritating file";
 110 }
 111 our($perl_path) = eval { dirname(dirname($perl)) };
 112 if (!$perl_path || $@) {
 113   die "ALERT: problem on dirname during '$parsefile': perl => '$perl': $@";
 114 }
 115 our $outdir = $parsefile or die "not true '$parsefile': $!";
 116 warn "Converting '$outdir'\n";
 117 $outdir =~ s/.(out|log)$/.d/ or die "...";
 118 mkpath $outdir;
 119 our $exte = $Opt{html} ? ".html" : ".xml";
 120 my $have_warned = {};
 121
 122 sub mystore ($$$$){
 123   my($shortdistro,$log,$ok,$seq) = @_;
 124   my $outfile = $shortdistro;
 125   $outfile =~ s!\.(tar.gz|tgz|tar.bz2|tbz|zip)?$!$exte!;
 126   $outfile =~ s|$|$exte| unless $outfile =~ /\Q$exte\E$/;
 127   $outfile =~ s|/|!|g;
 128   $outfile =~ s|^|$outdir/|;
 129   # megalog-2012-04-08T09:37:22.log
 130   my($time) = $outdir =~ /(\d{4}-\d{2}-\d{2}T\d{2}:\d{2}:\d{2})/;
 131   open my $fh, ">:utf8", $outfile or die "Could not open > '$outfile': $!";
 132   my $i = 0;
 133   $ok = "COULD_NOT_PARSE" unless defined $ok;
 134  ESTRING: for ($time,$perl_path,$shortdistro,$ok) {
 135     $i++;
 136     unless (defined) {
 137       warn "undefined something during shortdistro=$shortdistro,ok=$ok,seq=$seq,i=$i";
 138       next ESTRING;
 139     }
 140     s!\&!\&amp;!g;
 141     s!"!&quot;!g;
 142     s!<!&lt;!g;
 143     s!>!&gt;!g;
 144   }
 145   my $ulog = eval { require Encode::Detect; decode("Detect",$log) };
 146   if ($@) {
 147     unless ($have_warned->{Detect}++) {
 148       warn "error during decode/detect: $@";
 149       warn "during shortdistro=$shortdistro,ok=$ok,seq=$seq,i=$i";
 150     }
 151     $ulog = $log;
 152   }
 153   my $dumper = Dumpvalue->new(unctrl => "unctrl");
 154   $ulog =~ s/([\x00-\x09\x0b\x0c\x0e-\x1f])/ $dumper->stringify($1,1) /ge;
 155   $ulog =~ s|^</span>||;
 156   $ulog .= q|</span>| if $ulog =~ /<span[^<>]+>[^<]+$/;
 157   if ($Opt{html}) {
 158       $ulog = qq{<html xmlns="http://www.w3.org/1999/xhtml"><head><title>$shortdistro</title></head><body>
 159 <h2>Time: $time</h2>
 160 <h2>Perl: $perl_path</h2>
 161 <h2>Distro: $shortdistro</h2>
 162 <h2>Status: $ok</h2>
 163 <h2>Seq: $seq</h2>
 164 <pre style="font-size: x-large;"><b>$ulog</b></pre>
 165 </body></html>};
 166   } else {
 167       $ulog = qq{<distro time="$time" perl="$perl_path" distro="$shortdistro" ok="$ok" seq="$seq">$ulog</distro>\n};
 168   }
 169   if ($VERIFY_XML) {
 170     our $p;
 171     die "cannot parse '$shortdistro': [$ulog]" unless eval { $p->parse_string($ulog); 1 };
 172   }
 173   print $fh $ulog;
 174   close $fh or die "Could not close '$outfile': $!";
 175   sleep 1/96;
 176 }
 177
 178 sub measure ($) {
 179   warn sprintf "[%s] since last measure[%.4f]\n", shift, time - $start;
 180   $start = time;
 181 }
 182
 183 # the first part is a duplication of colorterm-to-html.pl which I
 184 # wrote for my Munich talk:
 185
 186 s/={10}monitoring proc \d+ perl \S+ secs [0-9\.]+={7}\n//g;
 187 my%h=("&"=>"&amp;",q!"!=>"&quot;","<"=>"&lt;",">"=>"&gt;");
 188 s/([&"<>])/$h{$1}/g;
 189 measure("&\"<>");
 190 s!\e\[1;3[45](?:;\d+)?m(.*?)\e\[0m!<span style="color: blue">$1</span>!sg;
 191 measure("blue");
 192 s!\e\[1;31(?:;\d+)?m(.*?)\e\[0m!<span style="color: red">$1</span>!sg;
 193 measure("red");
 194 #s!\n!<br/>\n!g;
 195 s!\r\n!\n!g;
 196 measure("CRLF");
 197
 198 our $HTMLSPANSTUFF = qr/(?:<[^<>]+>)*/;
 199 {
 200   my @lines = split /\n/, $_;
 201   measure("split");
 202   my %seq; # $seq{$shortdistro} = [];
 203   my @longdistro;
 204   my @shortdistro;
 205   my @leader;
 206   my $invalid;
 207   my $i = 0;
 208  LINE: while (defined($_ = shift @lines)) {
 209     s!.+?\r!!g;
 210     # $DB::single = /WWW-Sitemapper-1.110340/;
 211     if (0) {
 212     } elsif (/
 213                >\S+\Q is up to date \E\(
 214              /x) {
 215       # lines we ignore.
 216       next LINE;
 217     } elsif (/
 218                \Q>Running install for module '\E
 219              |
 220                \QWARNING: This key\E
 221              |
 222                \QSignature for \E
 223              |
 224                \QPrimary key fingerprint: \E
 225              |
 226                \QD i s t r o P r e f s\E
 227              |
 228                \Q\.yml\[\d+\]\E
 229              /x) {
 230       push @leader, $_;
 231       next LINE;
 232     } elsif (
 233              m!<span[^<>]+>
 234                (?:
 235                  Running\s(?:make|Build)\sfor\s(.+)
 236                  |
 237                  Checksum\sfor\s(.+)\sok
 238                )
 239                </span>
 240               !x
 241             ) {
 242       # lines where we say they introduce a new block and we expect
 243       # the following lines all to belong to this distro.
 244       # $DB::single=1;
 245       my $d = $1 || $2;
 246       $d =~ s|^.+/id/([A-Z]/[A-Z][A-Z]/)|$1|;
 247       if (!@longdistro or $d ne $longdistro[-1]) {
 248         push @longdistro, $d;
 249         $d =~ s|^[A-Z]/[A-Z][A-Z]/||;
 250         push @shortdistro, $d;
 251         $seq{$shortdistro[-1]} ||= [];
 252       }
 253       if (@leader) {
 254         push @{$seq{$shortdistro[-1]}}, @leader;
 255         @leader = ();
 256       }
 257     } elsif (@shortdistro and m|[ ]{2}\Q$shortdistro[-1]\E| and !m|----\s.+\s----|) {
 258       #### $DB::single = $shortdistro[-1] eq "JILLROWE/Runner-Init-2.23.tar.gz";
 259       # this may be the end of the block
 260       push @{$seq{$shortdistro[-1]}}, $_;
 261       my $end = 0;
 262       my $ok;
 263       if ($lines[0] =~ /[ ]{2}.+[ ]install[ ].*?--\s+((?:NOT\s)?OK|NA)/) {
 264         $ok = $1;
 265         push @{$seq{$shortdistro[-1]}}, shift @lines;
 266         $end = 1;
 267       } elsif ($lines[0] =~ /[ ]{2}(.+)\s+--\s+((?:NOT\s)?OK|NA)/) {
 268         my $command = $1;
 269         $ok = $2;
 270         push @{$seq{$shortdistro[-1]}}, shift @lines;
 271         if (    $ok =~ /\bNOT\b/
 272             and $command =~ /\b(?:make|Build|(?:Build|Makefile)\.PL|test)$/) {
 273           if ($invalid) {
 274             $ok = "DEPEFAIL";
 275           }
 276           $end = 1;
 277         }
 278         if ($lines[0] =~ /\bPrepending\b.*\bPERL5LIB\b/) {
 279           push @{$seq{$shortdistro[-1]}}, shift @lines;
 280         }
 281         if ($lines[0] =~ />Running.*test/
 282             && $lines[1] =~ />[ ]{2}/) {
 283           push @{$seq{$shortdistro[-1]}}, shift @lines;
 284           push @{$seq{$shortdistro[-1]}}, shift @lines;
 285           $end=1;
 286         }
 287         if ($lines[0] =~ />Running.*install/
 288             && $lines[1] =~ />[ ]{2}/) {
 289           push @{$seq{$shortdistro[-1]}}, shift @lines;
 290           push @{$seq{$shortdistro[-1]}}, shift @lines;
 291           $end=1;
 292         }
 293         if ($lines[0] =~ />\/\/hint\/\//) {
 294           push @{$seq{$shortdistro[-1]}}, shift @lines;
 295           push @{$seq{$shortdistro[-1]}}, shift @lines while $lines[0] =~ /^\s/;
 296           $end=1;
 297         }
 298       } elsif ($lines[0] =~ /Already done|Won't repeat unsuccessful test|Tests succeeded but|one dependency not OK|\d+ dependencies missing/) {
 299         push @{$seq{$shortdistro[-1]}}, shift @lines;
 300         $ok = "DEPEFAIL";
 301         $end=1;
 302       }
 303       if ($end) {
 304         # if we reached the end of one distro we pop this one off the
 305         # end of the "stack" of distros we have seen starting.
 306         $i++;
 307         unless ($i % 500){
 308           measure($i);
 309         }
 310         my $log = join "", map { "$_\n" } @{$seq{$shortdistro[-1]}};
 311         mystore($shortdistro[-1],$log,$ok,$i);
 312         $invalid = undef;
 313         delete $seq{$shortdistro[-1]};
 314         pop @longdistro;
 315         pop @shortdistro;
 316       }
 317       next LINE;
 318     } elsif (/CPAN::Reporter: test results were not valid, Prerequisite missing:|Warning: Prerequisite.*failed when processing/) {
 319       $invalid = 1;
 320     }
 321     # every line can be collected under the name of the last distro we
 322     # have identified. Before the first one we have nothing to collect
 323     if (@shortdistro) {
 324       push @{$seq{$shortdistro[-1]}}, $_;
 325     }
 326   } # while @lines
 327   # The residuum is a hash of distros we did not see finishing.
 328   # Usually this means they failed early or horribly
 329   my $residuumi = 0;
 330   for my $k (keys %seq) {
 331     $i++;
 332     $residuumi++;
 333     my $log = join "", map { "$_\n" } @{$seq{$k}};
 334     mystore($k,$log,"RESIDUUM",$i);
 335     delete $seq{$k};
 336   }
 337   measure($i);
 338   #open my $rfh, ">", "$outdir/residuum.yml" or die;
 339   #print $rfh YAML::Syck::Dump(\%seq);
 340   #close $rfh or die;
 341   warn "wrote a total of $i reports (among which $residuumi in state RESIDUUM)";
 342 }
 343
 344 if (-e $perl) {
 345   local $@;
 346   eval {
 347     open my $fh, ">", "$outdir/perl-V.txt" or die "Could not open >$outdir/perl-V.txt: $!";
 348     open my $pfh, "-|", $perl, "-V" or die "cannot fork: $!";
 349     while (<$pfh>) {
 350       print $fh $_;
 351     }
 352     close $pfh or die "perl died during -V";
 353     close $fh or die "could not write '$outdir/perl-V.txt': $!";
 354   };
 355   if ($@) {
 356     warn "Error while trying to run -V: '$@'";
 357   }
 358 }
 359
 360 __END__
 361
 362
 363 # Local Variables:
 364 # mode: cperl
 365 # cperl-indent-level: 2
 366 # End: