Make levelsToShow more variable

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

diff --git a/memnodes.pl b/memnodes.pl
index 3ca24f7..3f9a956 100644 (file)
--- a/memnodes.pl
+++ b/memnodes.pl
@@ -19,39 +19,43 @@ 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.'"';
-    };
+use HTML::Entities qw(encode_entities);;
+my $dotnode = sub {
+    my $name = encode_entities(shift);
+    $name =~ s/"/\\"/g;
+    return '"'.$name.'"';
+};
 
 print "memnodes = [" if $opt_json;
 
@@ -60,6 +64,14 @@ if ($opt_dot) {
     print "graph [overlap=false]\n"; # target="???", URL="???"
 }
 
+sub fmt_size {
+    my $size = shift;
+    my $kb = $size / 1024;
+    return $size if $kb < 5;
+    return sprintf "%.1fKb", $kb if $kb < 1000;
+    return sprintf "%.1fMb", $kb/1024;
+}
+
 
 sub enter_node {
     my $x = shift;
@@ -98,10 +110,40 @@ sub leave_node {
         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;
+        printf "// n%d parent=%s(type=%s)\n", $x->{id},
+                $parent ? $parent->{id} : "",
+                $parent ? $parent->{type} : ""
+            if 0;
+        if ($x->{type} != 2) {
+            my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
+
+            if ($x->{kids_size}) {
+                $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
+            }
+            else {
+                $name .= sprintf " +%s", fmt_size($x->{self_size});
+            }
+
+            my @node_attr = (
+                sprintf("label=%s", $dotnode->($name)),
+                "id=$x->{id}",
+            );
+            my @link_attr;
+            #if ($x->{name} eq 'hek') { push @node_attr, "shape=point"; push @node_attr, "labelfontsize=6"; }
+            if ($parent) { # probably a link
+                my $parent_id = $parent->{id};
+                my @link_attr = ("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});