388 lines
12 KiB
Perl
Executable File
388 lines
12 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
use strict 'vars';
|
|
use File::Spec;
|
|
|
|
my $traceLevel = 3;
|
|
|
|
# whether to box the clusters by sub-folder, but always color nodes regardless
|
|
my @clusterlist = qw(
|
|
/xml
|
|
/export
|
|
/menus
|
|
/effects/VST
|
|
/effects/ladspa
|
|
/effects/lv2
|
|
/effects/nyquist
|
|
/effects/vamp
|
|
);
|
|
my %clusters;
|
|
@clusters{@clusterlist} = ();
|
|
sub clustering
|
|
{
|
|
return exists( $clusters{ $_[0] } );
|
|
}
|
|
|
|
# whether to prune redundant arcs implied in transitive closure
|
|
my $pruning = 1;
|
|
|
|
# whether to insert hyperlinks
|
|
my $links = 1;
|
|
|
|
# Step 1: collect short names and paths to .cpp files
|
|
# We assume that final path components uniquely identify the files!
|
|
my $dir = "../src";
|
|
|
|
my %names; # string to string
|
|
{
|
|
foreach my $file (`find $dir -name '*.cpp' -o -name '*.h' -o -name '*.mm'`) {
|
|
my $short = $file;
|
|
chop $short;
|
|
$short =~ s|\.cpp$||;
|
|
$short =~ s|\.h$||;
|
|
$short =~ s|\.mm$||;
|
|
my $shorter = ($short =~ s|^.*/||r);
|
|
$names{$shorter} = $short;
|
|
}
|
|
}
|
|
|
|
#my $linkroot = "https://github.com/audacity/audacity/tree/master/src";
|
|
my $linkroot = "file://" . File::Spec->rel2abs( $dir );
|
|
|
|
|
|
print STDERR "Found ", scalar( keys %names ), " filename(s)\n" if $traceLevel >= 1;
|
|
|
|
# Step 2: collect inclusions in each .cpp/.h pair, and folder information,
|
|
# and build a graph
|
|
my $arcs = 0;
|
|
my %graph; # hash from names to sets of names
|
|
my $grepcmd = "grep '^ *# *include[^\"]*\"[^\"]*\\.h\"'"; # find include directives with quotes
|
|
my $sedcmd = "sed -E 's|^[^\"]*\"([^\"]*)\\.h\".*\$|\\1|'"; # extract quoted path
|
|
my %folders; # build our own tree like the directories
|
|
my $nFolders = 1;
|
|
while( my ($shorter, $short) = each(%names) ) {
|
|
# find relevant files (.cpp and .h, and sometimes .mm too)
|
|
my $pat = "${short}.*";
|
|
my @files = glob $pat;
|
|
|
|
# store path information, for subgraph clustering later
|
|
$short = substr $short, length( $dir ) + 1;
|
|
my @ownComponents = split '/', $short;
|
|
my $last = pop @ownComponents;
|
|
my $folder = \%folders;
|
|
# this improves the graph in some ways:
|
|
# files that we just put directly under src should be treated as if in
|
|
# a separate subfolder.
|
|
@ownComponents = ("UNCLASSIFIED") if not @ownComponents;
|
|
# store paths in a hash from strings to references to hashes from strings to references to ...
|
|
# (ensuring a nonempty set at key "" for each node of this tree)
|
|
while (@ownComponents) {
|
|
my $component = shift @ownComponents;
|
|
if (not exists $$folder{ $component }) {
|
|
my %empty = ("",());
|
|
$$folder{ $component } = \%empty;
|
|
++$nFolders;
|
|
}
|
|
$folder = $$folder{ $component };
|
|
}
|
|
# at the last folder, hash empty string specially, to the set of files
|
|
if (not exists $$folder{ "" }) {
|
|
my %empty = ("",());
|
|
$$folder{ "" } = \%empty;
|
|
}
|
|
$$folder{""}{$last} = ();
|
|
|
|
my %empty;
|
|
$graph{$shorter} = \%empty; # be sure leaf nodes are not omitted from hash
|
|
foreach (`cat @files | $grepcmd | $sedcmd`) {
|
|
chop;
|
|
my @components = split '/';
|
|
my $include = $components[-1];
|
|
# omit self-arcs and arcs to .h files external to the project
|
|
if (($shorter ne $include) && (exists $names{$include})) {
|
|
$graph{$shorter}{$include} = (), ++$arcs;
|
|
}
|
|
}
|
|
}
|
|
|
|
print STDERR "Found ", scalar( keys %graph ), " node(s) and ${arcs} arc(s)\n" if $traceLevel >= 1;
|
|
|
|
# Step 3: compute an acyclic quotient graph
|
|
|
|
my %quotientMap; # from node name to reference to array of node names
|
|
|
|
sub SCCID {
|
|
# given reference to an array of names
|
|
# use the first name in the array as an ID
|
|
my $scc = shift;
|
|
return $$scc[0];
|
|
}
|
|
|
|
sub SCCLabel {
|
|
# given reference to an array of names
|
|
# use concatenation of names as the displayed label
|
|
my $scc = shift;
|
|
return join "\n", @$scc;
|
|
}
|
|
|
|
my %quotientGraph; # to be populated, from SCC ID to array of:
|
|
# [ array of immediately reachable SCC IDs,
|
|
# array of transitively reachable SCC ids,
|
|
# rank number ]
|
|
# The first member may be pruned to only those nodes reachable by a longest
|
|
# path of length one
|
|
|
|
# find strongly connected components with Tarjan's algorithm, which discovers
|
|
# the nodes of the quotient graph in a bottom-up topologically sorted order
|
|
my %temp; # assigns numbers to node names
|
|
my $count = 1;
|
|
my @stack; # names
|
|
my $traceDepth = 0;
|
|
$arcs = 0;
|
|
my $prunedArcs = 0;
|
|
my $maxRank = -1;
|
|
my $largest = 0;
|
|
# three utility procedures for discovery of one s.c.c.
|
|
sub merge {
|
|
my ($a, $b) = @_;
|
|
my $na = @$a;
|
|
my $nb = @$b;
|
|
my @result;
|
|
while ($na && $nb) {
|
|
if ($$a[-$na] lt $$b[-$nb]) {
|
|
push @result, $$a[-($na--)];
|
|
}
|
|
elsif ($$b[-$nb] lt $$a[-$na]) {
|
|
push @result, $$b[-($nb--)];
|
|
}
|
|
else {
|
|
push @result, $$a[-($na--)]; $nb--;
|
|
}
|
|
}
|
|
push @result, $$a[-($na--)] while $na;
|
|
push @result, $$b[-($nb--)] while $nb;
|
|
@result;
|
|
}
|
|
sub diff {
|
|
my ($a, $b) = @_;
|
|
my $na = @$a;
|
|
my $nb = @$b;
|
|
my @result;
|
|
while ($na && $nb) {
|
|
if ($$a[-$na] lt $$b[-$nb]) {
|
|
push @result, $$a[-($na--)];
|
|
}
|
|
elsif ($$b[-$nb] lt $$a[-$na]) {
|
|
$nb--;
|
|
}
|
|
else {
|
|
$na--; $nb--;
|
|
}
|
|
}
|
|
push @result, $$a[-($na--)] while $na;
|
|
@result;
|
|
}
|
|
sub discoverOneComponent {
|
|
my ($sorted, $traceIndent) = @_; # reference to sorted array of names
|
|
# first populate the quotient map
|
|
foreach my $node (@$sorted) {
|
|
$quotientMap{ $node } = $sorted;
|
|
}
|
|
# now add arcs to the quotient graph
|
|
my $qhead = $$sorted[0]; # identifier of quotient node, agreeing with sub SCCID
|
|
$#{$quotientGraph{ $qhead }} = 2; # reserve results
|
|
my $data = $quotientGraph{ $qhead }; # reference to results
|
|
my $rank = -1;
|
|
my @reachable;
|
|
my %direct;
|
|
my @merged;
|
|
foreach my $node (@$sorted) {
|
|
my $tails = $graph{ $node };
|
|
foreach my $tail ( keys %$tails ) {
|
|
# it is guaranteed that all destination nodes are already in quotientMap,
|
|
# because of the bottom-up discovery sequence, so this works:
|
|
my $qtail = SCCID( $quotientMap{ $tail } );
|
|
$direct{ $qtail } = () if ( $qhead ne $qtail );
|
|
my $tailData = $quotientGraph{ $qtail };
|
|
my $tailRank = $$tailData[2];
|
|
$rank = $tailRank if $tailRank > $rank;
|
|
@reachable = merge( $$tailData[1], \@reachable );
|
|
}
|
|
}
|
|
++$rank;
|
|
my @direct = sort ( keys %direct ); # all direct arcs
|
|
my @pruned = diff( \@direct, \@reachable ); # all nonredundant direct arcs
|
|
$prunedArcs += @pruned; # count for trace information
|
|
$arcs += @direct; # count for trace information
|
|
@reachable = merge( \@pruned, \@reachable ); # all nodes reachable (excluding self)
|
|
$$data[0] = $pruning ? \@pruned : \@direct;
|
|
$$data[1] = \@reachable;
|
|
$$data[2] = $rank;
|
|
if ($traceLevel >= 3) {
|
|
print STDERR "${traceIndent}${qhead}";
|
|
print STDERR " and ", (scalar(@$sorted) - 1), " other(s)" if scalar(@$sorted) > 1;
|
|
print STDERR " discovered at rank ${rank}\n";
|
|
}
|
|
$maxRank = $rank if $rank > $maxRank;
|
|
$largest = @$sorted if @$sorted > $largest;
|
|
}
|
|
#recursive procedure
|
|
sub tarjan {
|
|
my ($name, $num) = @_;
|
|
my $traceIndent = " " x $traceDepth;
|
|
if ( exists( $temp{$name} ) ) {
|
|
# have visited
|
|
my $number = $temp{$name};
|
|
if ($number > 0) {
|
|
#scc not fully known
|
|
print STDERR "${traceIndent}${name} ${number} revisited\n" if $traceLevel >= 3;
|
|
return $number;
|
|
}
|
|
else {
|
|
#scc known
|
|
return $num; # unchanged
|
|
}
|
|
}
|
|
else {
|
|
# first visit
|
|
push @stack, $name;
|
|
$temp{$name} = my $number = $count++;
|
|
print STDERR "${traceIndent}${name} ${number} discovering\n" if $traceLevel >= 3;
|
|
|
|
# recur on directly reachable nodes
|
|
my $least = $number;
|
|
my $tails = $graph{$name};
|
|
++$traceDepth;
|
|
foreach my $name2 ( keys %$tails ) {
|
|
my $result = tarjan( $name2, $number );
|
|
$least = $result if $result < $least;
|
|
}
|
|
--$traceDepth;
|
|
|
|
if ($least == $number) {
|
|
# finished a component (this was the first discovered node in it)
|
|
my $node;
|
|
my @scc;
|
|
do {
|
|
$node = pop @stack;
|
|
$temp{ $node } = 0;
|
|
push @scc, $node;
|
|
} while( $node ne $name );
|
|
my @sorted = sort @scc;
|
|
discoverOneComponent( \@sorted, $traceIndent );
|
|
return $num; # unchanged
|
|
}
|
|
else {
|
|
# not finished
|
|
print STDERR "${traceIndent}${name} deferred to ${least}\n" if $traceLevel >= 3;
|
|
return $least;
|
|
}
|
|
}
|
|
}
|
|
# top invocation of recursive procedure discovers all
|
|
foreach my $node ( keys %graph ) {
|
|
tarjan( $node, 0 );
|
|
}
|
|
#give trace information
|
|
if ($traceLevel >= 1) {
|
|
print STDERR "Found ", scalar(keys(%quotientGraph)), " strongly connected component(s) in ", (1 + $maxRank), " rank(s)\n";
|
|
print STDERR "Largest component size is ${largest}\n";
|
|
print STDERR "${arcs} arc(s) found (${prunedArcs} after pruning)\n";
|
|
}
|
|
|
|
# Step 4: output the graph in dot language
|
|
print STDERR "Generating .dot file\n" if $traceLevel >= 1;
|
|
|
|
# temporary redirection
|
|
*OLD_STDOUT = *STDOUT;
|
|
my $fname = "graph.dot";
|
|
open my $fh, ">", $fname or die "Can't open file";
|
|
*STDOUT = $fh;
|
|
|
|
# header
|
|
my $graphAttr =
|
|
# $clustering ?
|
|
"labeljust=l labelloc=b"
|
|
# : ""
|
|
;
|
|
print "strict digraph{ graph [";
|
|
print $graphAttr;
|
|
print " newrank=true";
|
|
#print " mclimit=0.01";
|
|
#print " nslimit=1";
|
|
#print " rank=max";
|
|
#print " rankdir=LR";
|
|
print "]\n";
|
|
print "node [style=filled]";
|
|
|
|
# nodes and their clusters
|
|
# group the nodes into subgraphs corresponding to directories
|
|
print "\n";
|
|
print "// Nodes\n";
|
|
|
|
my $hue = 0;
|
|
my $saturation = 1.0;
|
|
my $huestep = 1.0 / $nFolders;
|
|
sub subgraph{
|
|
my ($foldername, $hashref) = @_;
|
|
my $clustered = clustering( $foldername );
|
|
my $cluster = $clustered ? "cluster" : "";
|
|
my $clusterAttr = $clustered ? "style=bold color=\"blue\"" : "";
|
|
print STDERR "subgraph \"$foldername\"\n" if $traceLevel >= 3;
|
|
my $color = "${hue},${saturation},1.0";
|
|
$hue += $huestep;
|
|
$saturation = 1.5 - $saturation; # alternate bold and pale
|
|
my $attrs = $clusterAttr . "label=\"$foldername\"";
|
|
print "\nsubgraph \"${cluster}${foldername}\" { $attrs node [fillcolor=\"${color}\"]\n";
|
|
# describe the nodes at this level, stored as a set (i.e. a hash to
|
|
# don't-care values) at key ""
|
|
foreach my $name (sort (keys %{$$hashref{""}})) {
|
|
next unless $name; # ignore dummy element
|
|
my $scc = $quotientMap{ $name };
|
|
my $id = SCCID( $scc );
|
|
# only want the name that is the representative of its s.c.c.
|
|
# equivalence class
|
|
next unless $name eq $id;
|
|
my $label = SCCLabel( $scc );
|
|
print " \"${id}\" [label=\"$label\"";
|
|
# insert other node attributes here as key=value pairs,
|
|
print " URL=\"${linkroot}${foldername}/${id}.cpp\"" if $links;
|
|
# separated by spaces
|
|
print"]\n";
|
|
}
|
|
# now recur, to describe nested clusters
|
|
foreach my $name ( sort( keys %$hashref ) ) {
|
|
next unless $name; # we just did the special entry at key "" above,
|
|
# which is a set of leaves at this level, not a subtree
|
|
subgraph( "${foldername}/${name}", $$hashref{ $name } );
|
|
}
|
|
print "}\n";
|
|
}
|
|
subgraph( "", \%folders );
|
|
|
|
# now describe the arcs
|
|
print "\n";
|
|
print "// Arcs\n";
|
|
|
|
while( my ($head, $data) = each( %quotientGraph ) ) {
|
|
foreach my $tail ( @{$$data[0]} ) {
|
|
print " \"$head\" -> \"$tail\" [";
|
|
# insert arc attributes here as key=value pairs,
|
|
print "penwidth=2.0";
|
|
# separated by spaces
|
|
print"]\n";
|
|
}
|
|
}
|
|
|
|
#footer
|
|
print "}\n";
|
|
|
|
# restore
|
|
*STDOUT = *OLD_STDOUT;
|
|
|
|
# Step 5: generate image
|
|
print STDERR "Generating image...\n" if $traceLevel >= 1;
|
|
my $verbosity = ($traceLevel >= 2) ? "-v" : "";
|
|
`dot $verbosity -O -Tsvg $fname`;
|
|
print STDERR "done\n" if $traceLevel >= 1;
|