bin/depthviz.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
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  22
  23 =item B<--help|h!>
  24
  25 This help
  26
  27 =item B<--tail!>
  28
  29 With tail, the end of file is ignored the program waits for new lines.
  30 Default is true on a tty, elsewhere default is false.
  31
  32 =back
  33
  34 =head1 DESCRIPTION
  35
  36
  37
  38 =cut
  39
  40
  41 use FindBin;
  42 use lib "$FindBin::Bin/../lib";
  43 BEGIN {
  44     push @INC, qw(       );
  45 }
  46
  47 use Dumpvalue;
  48 use File::Basename qw(dirname);
  49 use File::Path qw(mkpath);
  50 use File::Spec;
  51 use File::Temp;
  52 use Getopt::Long;
  53 use Pod::Usage;
  54 use Hash::Util qw(lock_keys);
  55
  56 our %Opt;
  57 lock_keys %Opt, map { /([^=|!]+)/ } @opt;
  58 GetOptions(\%Opt,
  59            @opt,
  60           ) or pod2usage(1);
  61 if ($Opt{help}) {
  62     pod2usage(0);
  63 }
  64 $Opt{tail} //= -t STDOUT;
  65
  66 use strict;
  67 use JSON::XS;
  68 use CPAN::Version;
  69 use Time::Moment;
  70 use Time::HiRes qw(sleep);
  71 use Graph::Feather; # schade, schade, verlangt 5.22; ==> distroprefs
  72 my $gf = Graph::Feather->new;
  73
  74 sub myts_to_tmom {
  75     my($ts) = @_;
  76     my @x0 = $ts =~ /^(\S+)-(\S+)-(\S+)[Tt ](\S+):(\S+):(\S+)\.(\d+)/
  77         or warn "strange date to parse '$ts' did not parse well";
  78     my $nano = $x0[6];
  79     $nano .= "0" while length($nano)<9;
  80     my $tm0 = eval { Time::Moment->new(
  81         year       => $x0[0],
  82         month      => $x0[1],
  83         day        => $x0[2],
  84         hour       => $x0[3],
  85         minute     => $x0[4],
  86         second     => $x0[5],
  87         nanosecond => $nano,
  88         offset     => 0,
  89         # precision  => 3,
  90         )} or die "error while feeding date (@x0) to Time::Moment: $@";
  91     return $tm0;
  92 }
  93
  94 sub tsums {
  95     my $t = shift;
  96     my %t;
  97     for my $i (0..$#$t) {
  98         no warnings 'uninitialized';
  99         my $tt = 0;
 100         if ($t->[$i][1] && $t->[$i][2]) {
 101             my $tm0 = myts_to_tmom($t->[$i][1]);
 102             my $tm1 = myts_to_tmom($t->[$i][2]);
 103             $tt = $tm0->delta_nanoseconds($tm1) / 1_000_000_000;
 104         }
 105         # printf "                       %-14s %-26s  %-26s %12.2f\n", @{$t->[$i]}, $tt;
 106         $t{$t->[$i][0]}=$tt;
 107     }
 108     return \%t;
 109 }
 110
 111 sub pred_walk {
 112     my($gf,$v) = @_;
 113     my @queue = map { [$_, 1] } $gf->predecessors($v);
 114     return sub {
 115         if (@queue) {
 116             my $node = shift @queue;
 117             my($name, $depth) = @$node;
 118             if (0 && $gf->get_vertex_attribute($name,"iscommand") > 0) {
 119                 @queue = ();
 120             } else {
 121                 push @queue, map {[$_, $depth+1]} $gf->predecessors($name);
 122             }
 123             return $node;
 124         } else {
 125             return;
 126         }
 127     }
 128 }
 129
 130 our($LINE,%LINE,%S,%T);
 131 my $file = shift or die "Usage: $0 file";
 132 open my $gw_fh, $file or die "Could not open $file: $!";
 133 $|=1;
 134 my $curpos;
 135 my $statusline;
 136 my $stalledtime;
 137 my $parallelo;
 138 seek($gw_fh, 0, 1);
 139 while () {
 140     LINE: for ($curpos = tell($gw_fh); <$gw_fh>; $curpos =tell($gw_fh)) {
 141         my $syslog = $1 if s/(^.+?)\{/{/;
 142         my $h = eval { decode_json($_); };
 143         if (! defined $h) {
 144             my $line = $_;
 145             my $errmsg = $@;
 146             my $dumper = Dumpvalue->new;
 147             $dumper->set_quote('"');
 148             my $line_dump = $dumper->stringify($line);
 149             my $errmsg_dump = $dumper->stringify($errmsg);
 150             warn "Could not parse line=$line_dump, errmsg=$errmsg_dump";
 151             next LINE;
 152         }
 153         if (exists $h->{CALLED_FOR} && ($h->{CALLED_FOR} eq "Chemistry::File::SMILES" || $h->{CALLED_FOR} eq "Chemistry::Ring")) {
 154             warn "Ignoring all loglines about $h->{CALLED_FOR} due circular deps noise";
 155             next LINE;
 156         }
 157         #next unless $h->{method} =~ /^post_(install)/;
 158         $h->{success} = "";
 159         if ($h->{make_test} && $h->{make_test} =~ /^(YES|NO)/) {
 160             my $yesno = $1;
 161             $h->{success} = $yesno;
 162             if ( $h->{method} =~ /^post_(?:install)/ ) {
 163                 $S{$yesno}++;
 164             }
 165         } else {
 166             if ( exists $h->{make}                && $h->{make} =~ /^NO/
 167                  || exists $h->{writemakefile}    && $h->{writemakefile} =~ /^NO/
 168                  || exists $h->{unwrapped}        && $h->{unwrapped} =~ /^NO/
 169                  || exists $h->{signature_verify} && $h->{signature_verify} =~ /^NO/ ) {
 170                 $h->{success} = "NO";
 171                 if ( $h->{method} =~ /^post_(?:install)/ ) {
 172                     $S{NO}++;
 173                 }
 174             }
 175         }
 176         $S{queue_size} = $h->{queue_size};
 177         my $line; # misnomer: I was thinking metaphorically of the
 178                   # line in the bundle file and/or the commandline the
 179                   # user has entered
 180         our %depth;
 181         if ($h->{reqtype} eq "c") {
 182             $line = $LINE{$h->{CALLED_FOR}} ||= ++$LINE;
 183             $line = sprintf "%5d", $line;
 184         } else {
 185             $line = $h->{reqtype};
 186         }
 187         $h->{line} = $line;
 188         if ($h->{success}) { # yes *or* no is success
 189             delete $depth{$h->{pretty_id}};
 190             $h->{depth}=1 + scalar keys %depth;
 191         } else {
 192             $depth{$h->{pretty_id}}=undef;
 193             $h->{depth}=scalar keys %depth;
 194         }
 195         $h->{mandatory_label} = $h->{reqtype} eq "c" ? '-' : $h->{mandatory} ? "m" : "o";
 196         my $x_minus_depth = 77 - $h->{depth};
 197         my ($ts) = $syslog =~ /^([-0-9]+[Tt ][:0-9]+(?:\.[0-9]+)?)/;
 198         if (1) {
 199             my $t = $T{$h->{pretty_id}} ||= [];
 200             my ($prepost,$phase) = $h->{method} =~ /(pre|post)_(.+)/;
 201             if ( $prepost eq "pre" ) {
 202                 push @$t, [ $phase, $ts, undef ];
 203             } else {
 204                 my $e = 0;
 205                 for (my $i= $#$t; $i>=0; $i--) {
 206                     if ( $phase eq $t->[$i][0] ) {
 207                         if ( $t->[$i][2] ) {
 208                             push @$t, [ $phase, undef, $ts ];
 209                         } else {
 210                             $t->[$i][2] = $ts;
 211                         }
 212                         $e = 1;
 213                         last;
 214                     }
 215                 }
 216                 unless ( $e ){
 217                     push @$t, [ $phase, undef, $ts ];
 218                 }
 219             }
 220             # print "             ($h->{pretty_id})";
 221         }
 222         my $t = tsums($T{$h->{pretty_id}});
 223 #        $gf->add_edge($h->{CALLED_FOR},$h->{pretty_id});
 224 #        if ($h->{reqtype} eq "c") {
 225 #            $gf->set_vertex_attribute($h->{CALLED_FOR},"iscommand",1);
 226 #        }
 227 #        $gf->set_vertex_attribute($h->{CALLED_FOR},"class","M");
 228 #        $gf->set_vertex_attribute($h->{pretty_id},"class","D");
 229 #        for my $prereq_cat (keys %{$h->{prereq_pm}}) {
 230 #            my $hash = $h->{prereq_pm}{$prereq_cat};
 231 #            for my $mod (keys %$hash) {
 232 #                $gf->add_edge($h->{pretty_id},$mod);
 233 #            }
 234 #        }
 235         if ( $h->{method} =~ /^post_(?:install)/ ) {
 236             $h->{success_label} = $h->{success} || "-";
 237             printf "\r%5s %s %2d %*s%-*s %-49s %-3s %8.3f %6d %s\n", @{$h}{qw(line mandatory_label depth depth)}, " ", $x_minus_depth, @{$h}{qw(pretty_id CALLED_FOR success_label)}, $t->{install}, $S{queue_size}, $ts;
 238 #            my $iterator = pred_walk($gf,$h->{pretty_id});
 239 #            my %seen;
 240 #            while (my $p = $iterator->()) {
 241 #                my($name, $depth) = @$p;
 242 #                my $class = $gf->get_vertex_attribute($name,"class");
 243 #                if ($class eq "D") {
 244 #                    last if $seen{$name}++;
 245 #                    printf "<========= pred %s(%d)[%s]\n", $name, $depth, $class;
 246 #                }
 247 #            }
 248         } elsif ($Opt{tail}) {
 249             $statusline = sprintf "\r%8s %-56s %11.2f %11.2f %11.2f %11.2f y%d:n%d %5d %s", "==t==",
 250                 $h->{pretty_id},
 251                 $t->{install}||0,
 252                 $t->{test}||0,
 253                 $t->{make}||0,
 254                 $t->{get}||0,
 255                 $S{YES}||0,
 256                 $S{NO}||0,
 257                 $S{queue_size}||0,
 258                 $ts
 259                 if defined $h->{pretty_id}
 260                 && defined $ts;
 261             $stalledtime = myts_to_tmom($ts)->epoch;
 262         }
 263     }
 264     if ($Opt{tail}) {
 265         my $waiting = time - $stalledtime;
 266         $parallelo ^= 1;
 267         printf "%s %5d  %s", $statusline,
 268             $waiting,
 269             $parallelo ? "▱": "▰"
 270             if $statusline;
 271         sleep 1;
 272         seek($gw_fh, $curpos, 0);  # seek to where we had been
 273     } else {
 274         last;
 275     }
 276 }
 277
 278 # print "yes $S{YES} no $S{NO} queue_size $S{queue_size}\n"
 279
 280 # Local Variables:
 281 # mode: cperl
 282 # cperl-indent-level: 4
 283 # End: