Lots of progress.

[p5sagit/Devel-Size.git] / static / MemView.pl

diff --git a/static/MemView.pl b/static/MemView.pl
index e17f344..d5b76be 100755 (executable)
--- a/static/MemView.pl
+++ b/static/MemView.pl
@@ -3,7 +3,13 @@
 use strict;
 use warnings;
 
+use JSON::XS;
 use Mojolicious::Lite;
+use Getopt::Long;
+
+GetOptions(
+    'db=s' => \(my $opt_db = '../x.db'),
+) or exit 1;
 
 use ORLite {
     file => '../x.db',
@@ -13,6 +19,8 @@ use ORLite {
     #unicode => 1,
 };
 
+my $j = JSON::XS->new;
+
 # Documentation browser under "/perldoc"
 plugin 'PODRenderer';
 
@@ -23,6 +31,8 @@ get '/' => sub {
 
 get '/jit_tree/:id/:depth' => sub {
     my $self = shift;
+    my $logarea = $self->param('logarea');
+
     my $id = $self->stash('id');
     my $depth = $self->stash('depth');
     warn "jit_tree $id $depth";
@@ -30,10 +40,11 @@ get '/jit_tree/:id/:depth' => sub {
     my $jit_tree = _transform_node_tree($node_tree, sub {
         my ($node) = @_;
         my $children = delete $node->{children}; # XXX edits the src tree
-        $node->{'$area'} = $node->{self_size}+$node->{kids_size};
+        my $area = $node->{self_size}+$node->{kids_size};
+        $node->{'$area'} = ($logarea) ? log($area) : $area;
         my $jit_node = {
             id   => $node->{id},
-            name => $node->{name},
+            name => $node->{title} || $node->{name},
             data => $node,
         };
         $jit_node->{children} = $children if $children;
@@ -42,50 +53,74 @@ get '/jit_tree/:id/:depth' => sub {
 if(1){
     use Devel::Dwarn;
     use Data::Dump qw(pp);
-#    local $jit_tree->{children};
+    local $jit_tree->{children};
     pp($jit_tree);
 }
     $self->render_json($jit_tree);
 };
 
-sub _merge_child_into_node {
-    my ($node, $child) = @_;
-  my $fake_data => {
-    "\$area"          => 23230,
-    "child_count"     => 2,
-    "child_seqns"     => "1414,1496",
-    "depth"           => 17,
-    "id"              => 1413,
-    "kids_node_count" => 83,
-    "kids_size"       => 23078,
-    "name"            => "SV(PVGV)",
-    "parent_seqn"     => 1412,
-    "self_size"       => 152,
-  };
-
-}
-
 sub _fetch_node_tree {
     my ($id, $depth) = @_;
     my $node = MemView->selectrow_hashref("select * from node where id = ?", undef, $id)
         or die "Node '$id' not found";
-    if ($depth && $node->{child_seqns}) {
-        my @child_seqns = split /,/, $node->{child_seqns};
+    $node->{leaves} = $j->decode(delete $node->{leaves_json});
+    $node->{attr}   = $j->decode(delete $node->{attr_json});
+
+    if ($node->{child_ids}) {
+        my @child_ids = split /,/, $node->{child_ids};
         my $children;
-        if (@child_seqns == -1) {
-            my $child = _fetch_node_tree($child_seqns[0], $depth); # same depth
-            _merge_child_into_node($node, $child);
+        if (@child_ids == 1) {
+            my $child = _fetch_node_tree($child_ids[0], $depth); # same depth
+            # merge node into child
+            # XXX id, depth, parent_id
+            warn "Merged $node->{name} #$node->{id} with only child $child->{name} #$child->{id}\n";
+            $child->{name} = "$node->{name} + $child->{name}";
+            $child->{$_} += $node->{$_} for (qw(self_size));
+            $child->{$_}  = $node->{$_} for (qw(parent_id));
+
+            $child->{title} = join " + ", grep { defined && length } $child->{title}, $node->{title};
+            warn "Titled $child->{title}" if $child->{title};
+
+            for my $attr_type (keys %{ $node->{attr} }) {
+                my $src = $node->{attr}{$attr_type};
+                if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value
+                    my $dst = $child->{attr}{$attr_type} ||= {};
+                    for my $k (keys %$src) {
+                        warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n"
+                            if defined $dst->{$k};
+                        $dst->{$k} = $src->{$k};
+                    }
+                }
+                else { # ARRAY eg NPattr_PADNAME: {attr}{2}[$val] = $name
+                    my $dst = $child->{attr}{$attr_type} ||= [];
+                    my $idx = @$src;
+                    while (--$idx >= 0) {
+                        warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n"
+                            if defined $dst->[$idx];
+                        $dst->[$idx] = $src->[$idx];
+                    }
+                }
+            }
+
+            $child->{leaves}{$_} += $node->{leaves}{$_}
+                for keys %{ $node->{leaves} };
+
+            $child->{_ids_merged} .= ",$node->{id}";
+            my @child_ids = split /,/, $node->{child_ids};
+            $child->{child_count} = @child_ids;
+
+            $node = $child;
         }
-        else {
-            $children = [ map { _fetch_node_tree($_, $depth-1) } @child_seqns ];
+        elsif ($depth) {
+            $children = [ map { _fetch_node_tree($_, $depth-1) } @child_ids ];
+            $node->{children} = $children;
+            $node->{child_count} = @$children;
         }
-        $node->{children} = $children;
-        $node->{child_count} = @$children;
     }
     return $node;
 }
 
-sub _transform_node_tree {  # depth first
+sub _transform_node_tree {  # recurse depth first
     my ($node, $transform) = @_;
     if (my $children = $node->{children}) {
         $_ = _transform_node_tree($_, $transform) for @$children;
@@ -135,6 +170,13 @@ Perl Memory TreeMap
 </div>
 
 <a id="back" href="#" class="theme button white">Go to Parent</a>
+
+<br />
+<form name=params>
+<label for="logarea">&nbsp;Logarithmic scale
+<input type=checkbox id="logarea" name="logarea">
+</form>
+
 </div>
 
 <div id="center-container">