new ticket from slaven
[andk-cpan-tools.git] / bin / colorout-to-dir-2.pl
blob6b07abc9dfbd4e906502a308a652a7e4c058daf9
1 #!/usr/bin/perl -0777 -nl
4 =pod
6 Second implementations with a state machine. Much shorter and even
7 correcter.
9 It's always an ugly step when going from text processing with console
10 escapes to XML processing
12 =cut
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;
24 our $VERIFY_XML = 0;
25 if ($VERIFY_XML) {
26 require XML::LibXML;
27 our $p = XML::LibXML->new;
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";
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!\&!\&!g;
48 s!"!"!g;
49 s!<!&lt;!g;
50 s!>!&gt;!g;
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 };
62 print $fh $ulog;
63 close $fh or die;
64 sleep 1/32;
67 sub measure ($) {
68 warn sprintf "[%s] since last measure[%.4f]\n", shift, time - $start;
69 sleep 1;
70 $start = time;
73 # the first part is a duplication of colorterm-to-html.pl which I
74 # wrote for my Munich talk:
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");
87 our $HTMLSPANSTUFF = qr/(?:<[^<>]+>)*/;
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;
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;
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;
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;
142 if ($end) {
143 $i++;
144 unless ($i % 100){
145 measure($i);
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;
153 next LINE;
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;
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 $_;
168 close $pfh or die "perl died during -V";
169 close $fh or die "could not write '$outdir/perl-V.txt': $!";
172 __END__