parcl

   1 #!/usr/bin/env perl
   2
   3 use warnings;
   4 use strict;
   5 use Devel::Dwarn;
   6 use Data::Dumper;
   7 use GraphViz;
   8
   9 =begin
  10          my $g = GraphViz->new();
  11
  12          $g->add_node('London');
  13          $g->add_node('Paris', label => 'City of\nlurve');
  14          $g->add_node('New York');
  15
  16          $g->add_edge('London' => 'Paris');
  17          $g->add_edge('London' => 'New York', label => 'Far');
  18          $g->add_edge('Paris' => 'London');
  19
  20          print $g->as_png;
  21 =cut
  22
  23
  24 my $data = do { local (@ARGV, $/) = 'callog'; <> };
  25
  26 my ($paths, $heads);
  27
  28 my $meta;
  29
  30 while ($data =~ /XXXXX(.+?)YYY/msg) {
  31   my @points = grep { $_ ne '(eval)' and $_ !~ /::(?: __ANON__ | BlockRunner::_?run | try (?: \s+ \{\.\.\.\} \s* )? | txn_do | preserve_context | MOP::Class:::around)$/x  } reverse $1 =~ /invoked as (.+?) at /g;
  32
  33   while ($points[0] !~ /^DBIx/) {
  34     shift @points;
  35   }
  36
  37   push @points, '_resolve_column_info';
  38
  39   for (1..$#points) {
  40     $meta->{$points[$_-1]}{$points[$_]}++;
  41   }
  42
  43 #  my @pp;
  44 #  for (0..$#points) {
  45 #    push @pp, sprintf '%s-> %s', ' ' x (2*$_), $points[$_];
  46 #  }
  47 #  my $ppid = join "\n", '', @pp;
  48 #
  49 #  unless ($paths->{$ppid}) {
  50 #    $paths->{$ppid}{points} = \@points;
  51 #    push @{$heads->{$points[0]}}, $ppid;
  52 #  }
  53 #  $paths->{$ppid}{callcount}++;
  54 }
  55
  56 my $cluster_re = qr/^
  57   DBIx::Class:: (
  58     Storage::DBIHacks | Storage::DBI(?=(?:Hacks)?::) | SQLMaker
  59   ) .*? ::[^:]+
  60 $/x;
  61
  62 my $g = GraphViz->new( layout => 'dot', node => { shape => 'box' }, concetrate => 1, ratio => 'auto' );
  63 for my $f (keys %$meta) {
  64
  65   $g->add_node($f, cluster => ($f =~ $cluster_re)[0]||'' );
  66   for my $t (keys %{$meta->{$f}}) {
  67     $g->add_node($t, cluster => ($t =~ $cluster_re)[0]||'' );
  68     $g->add_edge(
  69       $f => $t,
  70 #      taillabel => $f,
  71       label => $meta->{$f}{$t},
  72     );
  73   }
  74 }
  75
  76 $g->as_svg('grph.svg');
  77
  78
  79 __END__
  80
  81 PATH:
  82 for my $p (keys %$paths) {
  83   for ( reverse ( 0 .. $#{$paths->{$p}{points}} ) ) {
  84     if ( my $n = $heads->{$paths->{$p}{points}[$_]} ) {
  85       die Dumper $n;
  86     }
  87   }
  88 }
  89
  90 die Dumper [ keys %$paths ];