util/visualize_c3.pl

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 =pod
   7
   8 This is a visualization tool to help with
   9 understanding large MI hierarchies. It will
  10 output a DOT file for rendering with Graphviz.
  11
  12 NOTE:
  13 This program is currently very primative, and
  14 may break under some circumstances. If you
  15 encounter one of those circumstances, please
  16 email me about it so that I can improve this
  17 tool.
  18
  19 GRAPH LEGEND:
  20 In the graphs the green arrows are the ISA,
  21 and the red arrows are the C3 dispatch order.
  22
  23 =cut
  24
  25 use Class::C3 ();
  26
  27 @ARGV || die "usage : visualize_c3.pl <class-to-visualize> | <file-to-load> <class-to-visualize> <file-to-output>";
  28
  29 my ($class, $OUT);
  30 if (scalar @ARGV == 1) {
  31     $class = shift @ARGV;
  32     eval "use $class";
  33     die "Could not load '$class' :\n$@" if $@;
  34 }
  35 else {
  36     my $file = shift @ARGV;
  37     $class = shift @ARGV;
  38     $OUT = shift @ARGV;
  39     do $file;
  40     die "Could not load '$file' :\n$@" if $@;
  41 }
  42
  43 Class::C3->initialize();
  44
  45 my @MRO = Class::C3::calculateMRO($class);
  46
  47 sub get_class_str {
  48     my $class = shift;
  49     (join "_" => (split '::' => $class));
  50 }
  51
  52 my $output = "graph test {\n";
  53
  54 my $prev;
  55 foreach my $class (@MRO) {
  56     my $class_str = get_class_str($class);
  57     $output .= "node_${class_str} [ label = \"" . $class . "\" ];\n";
  58     {
  59         no strict 'refs';
  60         foreach my $super (@{"${class}::ISA"}) {
  61             $output .= "node_" . get_class_str($super) .
  62                        " -- node_${class_str}" .
  63                        " [ dir = back, color = green ];\n";
  64         }
  65     }
  66     if ($prev) {
  67         $output .= "node_${class_str} -- node_${prev}  [ dir = back, color = red ];\n";
  68     }
  69     $prev = $class_str;
  70 }
  71
  72 $output .= "}\n";
  73
  74 warn $output;
  75
  76 if ($OUT) {
  77     open OUT, ">", $OUT || die "could not open '$OUT' for output";
  78     print OUT $output;
  79     close OUT;
  80 }
  81 else {
  82     print $output;
  83 }