bin/colorout-to-dir-2.pl

   1 #!/usr/bin/perl -0777 -nl
   2
   3
   4 =pod
   5
   6 Second implementations with a state machine. Much shorter and even
   7 correcter.
   8
   9 It's always an ugly step when going from text processing with console
  10 escapes to XML processing
  11
  12 =cut
  13
  14
  15 use strict;
  16 use Dumpvalue;
  17 use Encode qw(decode);
  18 use Encode::Detect ();
  19 use File::Path qw(mkpath);
  20 use List::MoreUtils qw(uniq);
  21 use Time::HiRes qw(sleep time);
  22 use YAML::Syck;
  23
  24 our $VERIFY_XML = 0;
  25 if ($VERIFY_XML) {
  26   require XML::LibXML;
  27   our $p = XML::LibXML->new;
  28 }
  29 our $start = time;
  30 our($perl_path) = m|(/home\S+/installed-perls/(?:.*?)/p.*?/perl-5.*?@(?:\d+))|;
  31 our $outdir = $ARGV;
  32 warn "Converting '$outdir'\n";
  33 $outdir =~ s/.out$/.d/ or die;
  34 mkpath $outdir;
  35 my $perl = "$perl_path/bin/perl";
  36
  37 sub mystore ($$$$){
  38   my($shortdistro,$log,$ok,$seq) = @_;
  39   my $outfile = $shortdistro;
  40   $outfile =~ s!\.(tar.gz|tgz|tar.bz2|tbz|zip)?$!.xml!;
  41   $outfile =~ s|$|.xml| unless $outfile =~ /\.xml$/;
  42   $outfile =~ s|/|!|g;
  43   $outfile =~ s|^|$outdir/|;
  44   my($time) = $outdir =~ /(\d{8}T\d{4})/;
  45   open my $fh, ">:utf8", $outfile or die;
  46   for ($time,$perl_path,$shortdistro,$ok) {
  47     s!\&!\&amp;!g;
  48     s!"!&quot;!g;
  49     s!<!&lt;!g;
  50     s!>!&gt;!g;
  51   }
  52   my $ulog = decode("Detect",$log);
  53   my $dumper = Dumpvalue->new(unctrl => "unctrl");
  54   $ulog =~ s/([\x00-\x09\x0b\x0c\x0e-\x1f])/ $dumper->stringify($1,1) /ge;
  55   $ulog =~ s|^</span>||;
  56   $ulog .= q|</span>| if $ulog =~ /<span[^<>]+>[^<]+$/;
  57   $ulog = qq{<distro time="$time" perl="$perl_path" distro="$shortdistro" ok="$ok" seq="$seq">$ulog</distro>\n};
  58   if ($VERIFY_XML) {
  59     our $p;
  60     die "cannot parse '$shortdistro': [$ulog]" unless eval { $p->parse_string($ulog); 1 };
  61   }
  62   print $fh $ulog;
  63   close $fh or die;
  64   sleep 1/32;
  65 }
  66
  67 sub measure ($) {
  68   warn sprintf "[%s] since last measure[%.4f]\n", shift, time - $start;
  69   sleep 1;
  70   $start = time;
  71 }
  72
  73 # the first part is a duplication of colorterm-to-html.pl which I
  74 # wrote for my Munich talk:
  75
  76 my%h=("&"=>"&amp;",q!"!=>"&quot;","<"=>"&lt;",">"=>"&gt;");
  77 s/([&"<>])/$h{$1}/g;
  78 measure("&\"<>");
  79 s!\e\[1;3[45](?:;\d+)?m(.*?)\e\[0m!<span style="color: blue">$1</span>!sg;
  80 measure("blue");
  81 s!\e\[1;31(?:;\d+)?m(.*?)\e\[0m!<span style="color: red">$1</span>!sg;
  82 measure("red");
  83 #s!\n!<br/>\n!g;
  84 s!\r\n!\n!g;
  85 measure("CRLF");
  86
  87 our $HTMLSPANSTUFF = qr/(?:<[^<>]+>)*/;
  88 {
  89   my @lines = split /\n/, $_;
  90   measure("split");
  91   my %seq; # $seq{$shortdistro} = [];
  92   my @longdistro;
  93   my @shortdistro;
  94   my $i = 0;
  95  LINE: while (defined($_ = shift @lines)) {
  96     s!.+?\r!!g;
  97     if (/
  98          \Q>Running install for module '\E
  99          |>\S+\Q is up to date \E\(
 100          /x) {
 101       next LINE;
 102     } elsif (m!<span[^<>]+>Running (?:make|Build) for (.+)!) {
 103       $DB::single=1;
 104       my $d = $1;
 105       $d =~ s|</span>$||;
 106       push @longdistro, $d;
 107       $d =~ s|^[A-Z]/[A-Z][A-Z]/||;
 108       push @shortdistro, $d;
 109       $seq{$shortdistro[-1]} ||= [];
 110     } elsif (m|[ ]{2}\Q$shortdistro[-1]\E|) {
 111       push @{$seq{$shortdistro[-1]}}, $_;
 112       my $end = 0;
 113       my $ok;
 114       if ($lines[0] =~ /[ ]{2}.+[ ]install[ ].*?--\s+((?:NOT\s)?OK|NA)/) {
 115         $ok = $1;
 116         push @{$seq{$shortdistro[-1]}}, shift @lines;
 117         $end = 1;
 118       } elsif ($lines[0] =~ /[ ]{2}.+\s+--\s+((?:NOT\s)?OK|NA)/) {
 119         $ok = $1;
 120         push @{$seq{$shortdistro[-1]}}, shift @lines;
 121         if ($lines[0] =~ /\bPrepending\b.*\bPERL5LIB\b/) {
 122           push @{$seq{$shortdistro[-1]}}, shift @lines;
 123         }
 124         if ($lines[0] =~ />Running.*test/
 125             && $lines[1] =~ />[ ]{2}/) {
 126           push @{$seq{$shortdistro[-1]}}, shift @lines;
 127           push @{$seq{$shortdistro[-1]}}, shift @lines;
 128           $end=1;
 129         }
 130         if ($lines[0] =~ />Running.*install/
 131             && $lines[1] =~ />[ ]{2}/) {
 132           push @{$seq{$shortdistro[-1]}}, shift @lines;
 133           push @{$seq{$shortdistro[-1]}}, shift @lines;
 134           $end=1;
 135         }
 136         if ($lines[0] =~ />\/\/hint\/\//) {
 137           push @{$seq{$shortdistro[-1]}}, shift @lines;
 138           push @{$seq{$shortdistro[-1]}}, shift @lines while $lines[0] =~ /^\s/;
 139           $end=1;
 140         }
 141       }
 142       if ($end) {
 143         $i++;
 144         unless ($i % 100){
 145           measure($i);
 146         }
 147         my $log = join "", map { "$_\n" } @{$seq{$shortdistro[-1]}};
 148         mystore($shortdistro[-1],$log,$ok,$i);
 149         delete $seq{$shortdistro[-1]};
 150         pop @longdistro;
 151         pop @shortdistro;
 152       }
 153       next LINE;
 154     }
 155     push @{$seq{$shortdistro[-1]}}, $_;
 156   } # while @lines
 157   open my $rfh, ">", "$outdir/residuum.yml" or die;
 158   print $rfh YAML::Syck::Dump(\%seq);
 159   close $rfh or die;
 160 }
 161
 162 if (-e $perl) {
 163   open my $fh, ">", "$outdir/perl-V.txt" or die "Could not open >$outdir/perl-V.txt: $!";
 164   open my $pfh, "-|", $perl, "-V" or die "cannot fork: $!";
 165   while (<$pfh>) {
 166     print $fh $_;
 167   }
 168   close $pfh or die "perl died during -V";
 169   close $fh or die "could not write '$outdir/perl-V.txt': $!";
 170 }
 171
 172 __END__