From: Tim Bunce <Tim.Bunce@pobox.com>
Date: Sat, 22 Sep 2012 10:44:36 +0000 (+0100)
Subject: add basic dot format output
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ee2793c171caaee30fbfa2e738d8adb0ce43d614;p=p5sagit%2FDevel-Size.git

add basic dot format output
---

diff --git a/Size.xs b/Size.xs
index d4cf11f..1a5e573 100644
--- a/Size.xs
+++ b/Size.xs
@@ -300,8 +300,8 @@ np_dump_node_path_info(struct state *st, npath_node_t *npath_node, UV attr_type,
 
 int
 np_stream_formatted_node(struct state *st, npath_node_t *npath_node, npath_node_t *npath_node_deeper) {
-    fprintf(st->node_stream, "N %lu %u ", npath_node->seqn,
-        (unsigned)npath_node->depth
+    fprintf(st->node_stream, "-%u %lu %u ",
+        npath_node->type, npath_node->seqn, (unsigned)npath_node->depth
     );
     np_print_node_name(st->node_stream, npath_node);
     fprintf(st->node_stream, "\n");
diff --git a/memnodes.pl b/memnodes.pl
index cbe4936..3ca24f7 100644
--- a/memnodes.pl
+++ b/memnodes.pl
@@ -11,6 +11,7 @@ use Getopt::Long;
 
 GetOptions(
     'json!' => \my $opt_json,
+    'dot!' => \my $opt_dot,
     'db=s'  => \my $opt_db,
     'verbose|v!' => \my $opt_verbose,
     'debug|d!' => \my $opt_debug,
@@ -46,21 +47,42 @@ my $node_ins_sth = $dbh->prepare(q{
 my @stack;
 my %seqn2node;
 
+    my $dotnode = sub {
+        my $name = shift;
+        $name =~ s/"/\\"/g;
+        return '"'.$name.'"';
+    };
+
+print "memnodes = [" if $opt_json;
+
+if ($opt_dot) {
+    print "digraph {\n"; # }
+    print "graph [overlap=false]\n"; # target="???", URL="???"
+}
+
+
 sub enter_node {
     my $x = shift;
     if ($opt_json) {
         print "    " x $x->{depth};
         print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
     }
+    if ($opt_dot) {
+        #printf $fh qq{\tn%d [ %s ]\n}, $x->{id}, $dotnode->($x->{name});
+        #print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
+    }
     return;
 }
 
 sub leave_node {
     my $x = shift;
     delete $seqn2node{$x->{id}};
+
     my $self_size = 0; $self_size += $_  for values %{$x->{leaves}};
     $x->{self_size} = $self_size;
-    if (my $parent = $stack[-1]) {
+
+    my $parent = $stack[-1];
+    if ($parent) {
         # link to parent
         $x->{parent_id} = $parent->{id};
         # accumulate into parent
@@ -75,6 +97,12 @@ sub leave_node {
         my $size = $self_size + $x->{kids_size};
         print qq(], "data":{ "\$area": $size } },\n);
     }
+    if ($opt_dot) {
+        my @attr = (sprintf "label=%s", $dotnode->($x->{name}));
+        push @attr, "shape=point" if $x->{type} == 2;
+        printf qq{n%d [ %s ];\n}, $x->{id}, join(",", @attr);
+        printf qq{n%d -> n%d;\n}, $parent->{id}, $x->{id} if $parent;
+    }
     if ($dbh) {
         my $attr_json = $j->encode($x->{attr});
         my $leaves_json = $j->encode($x->{leaves});
@@ -89,19 +117,18 @@ sub leave_node {
     return;
 }
 
-print "memnodes = [" if $opt_json;
 
 while (<>) {
     chomp;
     my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
-    if ($type eq "N") {     # Node ($val is depth)
+    if ($type =~ s/^-//) {     # Node type ($val is depth)
         while ($val < @stack) {
             leave_node(my $x = pop @stack);
             warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
                 if $opt_verbose;
         }
         die 1 if $stack[$val];
-        my $node = $stack[$val] = { id => $id, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
+        my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
         enter_node($node);
         $seqn2node{$id} = $node;
     }
@@ -141,6 +168,7 @@ while (@stack > 1) {
     warn "EOF ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n";
 }
 print " ];\n" if $opt_json;
+print "}\n" if $opt_dot;
 
 $dbh->commit if $dbh;