Use link nodes to label links.

[p5sagit/Devel-Size.git] / memnodes.pl

diff --git a/memnodes.pl b/memnodes.pl
index cbe4936..d998f3b 100644 (file)
--- 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,
@@ -18,49 +19,73 @@ GetOptions(
 
 my $j = JSON::XS->new->ascii->pretty(0);
 
-my $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
-    RaiseError => 1, PrintError => 0, AutoCommit => 0
-});
-$dbh->do("PRAGMA synchronous = OFF");
-$dbh->do("DROP TABLE IF EXISTS node");
-$dbh->do(q{
-    CREATE TABLE node (
-        id integer primary key,
-        name text,
-        title text,
-        depth integer,
-        parent_id integer,
-
-        self_size integer,
-        kids_size integer,
-        kids_node_count integer,
-        child_ids text,
-        attr_json text,
-        leaves_json text
-    )
-});
-my $node_ins_sth = $dbh->prepare(q{
-    INSERT INTO node VALUES (?,?,?,?,?,  ?,?,?,?,?,?)
-});
+my ($dbh, $node_ins_sth);
+if ($opt_db) {
+    $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
+        RaiseError => 1, PrintError => 0, AutoCommit => 0
+    });
+    $dbh->do("PRAGMA synchronous = OFF");
+    $dbh->do("DROP TABLE IF EXISTS node");
+    $dbh->do(q{
+        CREATE TABLE node (
+            id integer primary key,
+            name text,
+            title text,
+            depth integer,
+            parent_id integer,
+
+            self_size integer,
+            kids_size integer,
+            kids_node_count integer,
+            child_ids text,
+            attr_json text,
+            leaves_json text
+        )
+    });
+    $node_ins_sth = $dbh->prepare(q{
+        INSERT INTO node VALUES (?,?,?,?,?,  ?,?,?,?,?,?)
+    });
+}
 
 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 +100,27 @@ sub leave_node {
         my $size = $self_size + $x->{kids_size};
         print qq(], "data":{ "\$area": $size } },\n);
     }
+    if ($opt_dot) {
+        printf "// n%d parent=%s(type=%s)\n", $x->{id},
+            $parent ? $parent->{id} : "",
+            $parent ? $parent->{type} : "";
+        if ($x->{type} != 2) {
+            my @node_attr = (sprintf "label=%s", $dotnode->($x->{name}));
+            if ($parent) { # probably a link
+                my @link_attr;
+                my $parent_id = $parent->{id};
+                if ($parent->{type} == 2) { # link
+                    (my $link_name = $parent->{name}) =~ s/->$//;
+                    push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
+                    $parent_id = ($stack[-2]||die "panic")->{id};
+                }
+                printf qq{n%d -> n%d [%s];\n},
+                    $parent_id, $x->{id}, join(",", @link_attr);
+            }
+            printf qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
+        }
+
+    }
     if ($dbh) {
         my $attr_json = $j->encode($x->{attr});
         my $leaves_json = $j->encode($x->{leaves});
@@ -89,19 +135,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 +186,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;