Add `rdbl-luks`, git textconv diff filter for LUKS headers
[sunny256-utils.git] / dprofpp.graphviz
blob6072b51b48c205475552b49de6e7dc91c47c6117
1 #!/usr/bin/env perl
3 # dprofpp.graphviz
4 # File ID: eee09f82-6069-11de-b30a-000475e441b9
6 # This is a replacement for Devel::DProf's dproffpp,
7 # which instead produces a graph from the tmon.out
8 # file.
10 # Downloaded from
11 # http://cpansearch.perl.org/src/LBROCARD/GraphViz-2.04/examples/dprofpp.graphviz
13 # Example usage:
14 # perl -d:DProf test.pl
15 # dprofpp.graphviz tmon.out
17 # Will create a file _tmon.png
19 use strict;
20 use lib '..';
21 use GraphViz;
23 1 until <> eq "PART2\n";
25 my %package;
26 my %subroutine;
27 my %name;
28 my %id;
30 my %calls;
31 my %call_tree;
33 my @stack = (-1);
34 $package{-1} = 'main';
35 $subroutine{-1} = 'main';
36 $name{-1} = 'main::main';
38 my $maxcalls;
40 while (defined(my $line = <>)) {
41 chomp $line;
43 if (my($id, $package, $subroutine) = $line =~ m/^& (.+?) (.+?) (.+?)$/) {
44 my $name = "$package::$subroutine";
45 $name{$id} = $package . '::' . $subroutine;
46 $package{$id} = $package;
47 $subroutine{$id} = $subroutine;
48 } elsif (my($id) = $line =~ m/^\+ (.+?)$/) {
49 if (ignore($id)) {
50 $calls{$id}++;
51 $call_tree{$stack[-1]}{$id}++;
52 $maxcalls = $call_tree{$stack[-1]}{$id} > $maxcalls ? $call_tree{$stack[-1]}{$id} : $maxcalls;
54 push @stack, $id;
55 } elsif (my($id) = $line =~ m/^\- (.+?)$/) {
56 die "Pop problem!" unless $id = pop @stack;
60 warn "Stack not empty: (" . (join ', ', @stack) . ')!' if @stack > 1;
62 my %time;
63 my $maxtime = 0.00000001; # To avoid division by zero in traverse() on fast machines
65 my %id = reverse %name;
67 my $text = `dprofpp -q -O 50000 tmon.out`;
68 foreach my $line (split /\n/, $text) {
69 my(undef, $time, $excl, $cumul, $calls, $secspcall, $callspsec, $name) = split /\s+/, $line;
70 next unless ignore($id{$name});
71 $maxtime = $excl > $maxtime ? $excl : $maxtime;
72 $time{$id{$name}} = $excl;
73 # print "$name $excl\n";
76 my $g = GraphViz->new;
78 my %traversed;
80 traverse(-1);
82 sub traverse {
83 my $id = shift;
84 return if $traversed{$id}++;
86 my $count = $time{$id};
87 my $ratio = $count / $maxtime;
88 my $w = 100 * (1 - $ratio);
90 $g->add_node($name{$id}, label => $subroutine{$id}, cluster => $package{$id}, color => "0,1,$ratio", w => $w);
92 my @called = sort keys %{$call_tree{$id}};
94 foreach my $called_id (@called) {
95 traverse($called_id);
96 my $count = $call_tree{$id}{$called_id};
97 my $ratio = $count / $maxcalls;
98 my $w = 100 * (1 - $ratio);
101 $count = "" if $count == 1;
102 $g->add_edge($name{$id} => $name{$called_id}, label => $count, color => "0,1,$ratio", w => $w, len => 2);
106 #print $g->_as_debug;
107 open(FP, ">", "_tmon.png") || die("$0: tmon.png: Cannot create file: $!\n");
108 print(FP $g->as_png);
109 close(FP);
111 sub ignore {
112 my $id = shift;
113 return 0 if $subroutine{$id} eq 'BEGIN';
114 return 0 if $subroutine{$id} eq 'END';
115 return 0 if $subroutine{$id} eq '__ANON__';
116 # return 0 if $subroutine{$id} =~ /double|square|cons|id|flip|fst|snd|min|max/; # temporary for clarity
117 return 1;