13 colorout-to-dir-3.pl file
15 eg: perl ~k/sources/CPAN/andk-cpan-tools/bin/colorout-to-dir-3.pl --html megalog-2012-04-24T21:44:13.log
23 my @opt = <<'=back' =~ /B<--(\S+)>/g;
31 Do not produce XML but additional stuff so we get XHTML
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.
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.
51 The bad things that can happen:
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
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?
62 compare-megalogdirs.pl
68 use lib
"$FindBin::Bin/../lib";
74 use File
::Basename
qw(dirname);
75 use File
::Path
qw(mkpath);
79 use Hash
::Util
qw(lock_keys);
82 lock_keys
%Opt, map { /([^=\|\!]+)/ } @opt;
91 #!/usr/bin/perl -0777 -nl
92 my $parsefile = shift or pod2usage
(1);
94 use Encode
qw(decode);
95 use List
::MoreUtils
qw(uniq);
96 use Time
::HiRes
qw(sleep time);
102 our $p = XML
::LibXML
->new;
104 $_ = do { open my $fh, $parsefile or die "Could not open '$parsefile': $!"; local $/; <$fh> };
107 our($perl) = m!perl\|\-\>\s(/home\S+/installed-perls/(?:.*?)/bin/perl)\s!;
109 die "ALERT: Could not find a valid path to a perl in '$parsefile', maybe remove this irritating file";
111 our($perl_path) = eval { dirname
(dirname
($perl)) };
112 if (!$perl_path || $@
) {
113 die "ALERT: problem on dirname during '$parsefile': perl => '$perl': $@";
115 our $outdir = $parsefile or die "not true '$parsefile': $!";
116 warn "Converting '$outdir'\n";
117 $outdir =~ s/.(out|log)$/.d/ or die "...";
119 our $exte = $Opt{html
} ?
".html" : ".xml";
120 my $have_warned = {};
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$/;
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': $!";
133 $ok = "COULD_NOT_PARSE" unless defined $ok;
134 ESTRING
: for ($time,$perl_path,$shortdistro,$ok) {
137 warn "undefined something during shortdistro=$shortdistro,ok=$ok,seq=$seq,i=$i";
145 my $ulog = eval { require Encode
::Detect
; decode
("Detect",$log) };
147 unless ($have_warned->{Detect
}++) {
148 warn "error during decode/detect: $@";
149 warn "during shortdistro=$shortdistro,ok=$ok,seq=$seq,i=$i";
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
[^<>]+>[^<]+$/;
158 $ulog = qq{<html xmlns
="http://www.w3.org/1999/xhtml"><head
><title
>$shortdistro</title></head
><body
>
160 <h2
>Perl
: $perl_path</h2
>
161 <h2
>Distro
: $shortdistro</h2
>
164 <pre style
="font-size: x-large;"><b
>$ulog</b></pre
>
167 $ulog = qq{<distro
time="$time" perl
="$perl_path" distro
="$shortdistro" ok
="$ok" seq
="$seq">$ulog</distro
>\n};
171 die "cannot parse '$shortdistro': [$ulog]" unless eval { $p->parse_string($ulog); 1 };
174 close $fh or die "Could not close '$outfile': $!";
179 warn sprintf "[%s] since last measure[%.4f]\n", shift, time - $start;
183 # the first part is a duplication of colorterm-to-html.pl which I
184 # wrote for my Munich talk:
186 s/={10}monitoring proc \d+ perl \S+ secs [0-9\.]+={7}\n//g;
187 my%h=("&"=>"&",q
!"!=>""
;","<"=>"<",">"=>">");
190 s!\e\[1;3[45](?:;\d+)?m(.*?)\e\[0m!<span style="color: blue">$1</span>!sg;
192 s!\e\[1;31(?:;\d+)?m(.*?)\e\[0m!<span style="color: red">$1</span>!sg;
198 our $HTMLSPANSTUFF = qr/(?:<[^<>]+>)*/;
200 my @lines = split /\n/, $_;
202 my %seq; # $seq{$shortdistro} = [];
208 LINE: while (defined($_ = shift @lines)) {
210 # $DB::single = /WWW-Sitemapper-1.110340/;
213 >\S+\Q is up to date \E\(
218 \Q>Running install for module '\E
220 \QWARNING: This key\E
224 \QPrimary key fingerprint: \E
226 \QD i s t r o P r e f s\E
235 Running\s(?:make|Build)\sfor\s(.+)
237 Checksum\sfor\s(.+)\sok
242 # lines where we say they introduce a new block and we expect
243 # the following lines all to belong to this distro.
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]} ||= [];
254 push @{$seq{$shortdistro[-1]}}, @leader;
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]}}, $_;
263 if ($lines[0] =~ /[ ]{2}.+[ ]install[ ].*?--\s+((?:NOT\s)?OK|NA)/) {
265 push @{$seq{$shortdistro[-1]}}, shift @lines;
267 } elsif ($lines[0] =~ /[ ]{2}(.+)\s+--\s+((?:NOT\s)?OK|NA)/) {
270 push @{$seq{$shortdistro[-1]}}, shift @lines;
271 if ( $ok =~ /\bNOT\b/
272 and $command =~ /\b(?:make|Build|(?:Build|Makefile)\.PL|test)$/) {
278 if ($lines[0] =~ /\bPrepending\b.*\bPERL5LIB\b/) {
279 push @{$seq{$shortdistro[-1]}}, shift @lines;
281 if ($lines[0] =~ />Running.*test/
282 && $lines[1] =~ />[ ]{2}/) {
283 push @{$seq{$shortdistro[-1]}}, shift @lines;
284 push @{$seq{$shortdistro[-1]}}, shift @lines;
287 if ($lines[0] =~ />Running.*install/
288 && $lines[1] =~ />[ ]{2}/) {
289 push @{$seq{$shortdistro[-1]}}, shift @lines;
290 push @{$seq{$shortdistro[-1]}}, shift @lines;
293 if ($lines[0] =~ />\/\/hint\/\//) {
294 push @{$seq{$shortdistro[-1]}}, shift @lines;
295 push @{$seq{$shortdistro[-1]}}, shift @lines while $lines[0] =~ /^\s/;
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;
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.
310 my $log = join "", map { "$_\n" } @{$seq{$shortdistro[-1]}};
311 mystore($shortdistro[-1],$log,$ok,$i);
313 delete $seq{$shortdistro[-1]};
318 } elsif (/CPAN::Reporter: test results were not valid, Prerequisite missing:|Warning: Prerequisite.*failed when processing/) {
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
324 push @{$seq{$shortdistro[-1]}}, $_;
327 # The residuum is a hash of distros we did not see finishing.
328 # Usually this means they failed early or horribly
330 for my $k (keys %seq) {
333 my $log = join "", map { "$_\n" } @{$seq{$k}};
334 mystore($k,$log,"RESIDUUM
",$i);
338 #open my $rfh, ">", "$outdir/residuum
.yml
" or die;
339 #print $rfh YAML::Syck::Dump(\%seq);
341 warn "wrote a total of
$i reports
(among which
$residuumi in state RESIDUUM
)";
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: $!";
352 close $pfh or die "perl died during
-V
";
353 close $fh or die "could
not write '$outdir/perl-V.txt': $!";
356 warn "Error
while trying to run
-V
: '$@'";
365 # cperl-indent-level: 2