static/MemView.pl

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use JSON::XS;
   7 use Mojolicious::Lite;
   8 use Getopt::Long;
   9 use Storable qw(dclone);
  10 use Devel::Dwarn;
  11
  12 GetOptions(
  13     'db=s' => \(my $opt_db = '../memnodes.db'),
  14     'debug!' => \my $opt_debug,
  15 ) or exit 1;
  16
  17 #warn "Reading from $opt_db\n";
  18
  19 use ORLite {
  20     file => '../memnodes.db',
  21     package => "MemView",
  22     #user_version => 1,
  23     readonly => 1,
  24     #unicode => 1,
  25 };
  26
  27 my $j = JSON::XS->new;
  28
  29 # Documentation browser under "/perldoc"
  30 plugin 'PODRenderer';
  31
  32 get '/' => sub {
  33     my $self = shift;
  34     $self->render('index');
  35 };
  36
  37 get '/jit_tree/:id/:depth' => sub {
  38     my $self = shift;
  39
  40     my $id = $self->stash('id');
  41     my $depth = $self->stash('depth');
  42
  43     my $logarea = (defined $self->param('logarea'))
  44         ? $self->param('logarea')
  45         : Mojo::URL->new($self->req->headers->referrer)->query->param('logarea');
  46
  47     my $node_tree = _fetch_node_tree($id, $depth);
  48     my $jit_tree = _transform_node_tree($node_tree, sub {
  49         my ($node) = @_;
  50         my $children = delete $node->{children}; # XXX edits the src tree
  51         my $area = $node->{self_size}+$node->{kids_size};
  52         $node->{'$area'} = ($logarea) ? log($area) : $area; # XXX move to jit js
  53         my $jit_node = {
  54             id   => $node->{id},
  55             name => $node->{title} || $node->{name},
  56             data => $node,
  57         };
  58         $jit_node->{children} = $children if $children;
  59         return $jit_node;
  60     });
  61
  62     if(1){
  63         use Devel::Dwarn;
  64         use Data::Dump qw(pp);
  65         local $jit_tree->{children};
  66         pp(dclone($jit_tree)); # dclone to avoid stringification
  67     }
  68
  69     $self->render_json($jit_tree);
  70 };
  71
  72 sub _fetch_node_tree {
  73     my ($id, $depth) = @_;
  74     my $node = MemView->selectrow_hashref("select * from node where id = ?", undef, $id)
  75         or die "Node '$id' not found";
  76     $node->{$_} += 0 for (qw(child_count kids_node_count kids_size self_size));
  77     $node->{leaves} = $j->decode(delete $node->{leaves_json});
  78     $node->{attr}   = $j->decode(delete $node->{attr_json});
  79     $node->{name} .= "->" if $node->{type} == 2 && $node->{name};
  80
  81     if ($node->{child_ids}) {
  82         my @child_ids = split /,/, $node->{child_ids};
  83         my $children;
  84         if (@child_ids == 1
  85             && $node->{type} == 2 # only collapse links
  86         ) {
  87             my $child = _fetch_node_tree($child_ids[0], $depth); # same depth
  88             # merge node into child
  89             # XXX id, depth, parent_id
  90             warn "Merged $node->{name} #$node->{id} with only child $child->{name} #$child->{id}\n"
  91                 if $opt_debug;
  92             $child->{name} = "$node->{name} $child->{name}";
  93             $child->{$_} += $node->{$_} for (qw(self_size));
  94             $child->{$_}  = $node->{$_} for (qw(parent_id));
  95
  96             $child->{title} = join " ", grep { defined && length } $child->{title}, $node->{title};
  97             #warn "Titled $child->{title}" if $child->{title};
  98
  99             for my $attr_type (keys %{ $node->{attr} }) {
 100                 my $src = $node->{attr}{$attr_type};
 101                 if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value
 102                     my $dst = $child->{attr}{$attr_type} ||= {};
 103                     for my $k (keys %$src) {
 104                         warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n"
 105                             if defined $dst->{$k};
 106                         $dst->{$k} = $src->{$k};
 107                     }
 108                 }
 109                 elsif (ref $src eq 'ARRAY') { # eg NPattr_PADNAME: {attr}{2}[$val] = $name
 110                     my $dst = $child->{attr}{$attr_type} ||= [];
 111                     my $idx = @$src;
 112                     while (--$idx >= 0) {
 113                         warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n"
 114                             if defined $dst->[$idx];
 115                         $dst->[$idx] = $src->[$idx];
 116                     }
 117                 }
 118                 else { # assume scalar
 119                     warn "Node $child->{id} attr $attr_type=$child->{attr}{$attr_type} overwritten by $src\n"
 120                         if exists $child->{attr}{$attr_type};
 121                     $child->{attr}{$attr_type} = $src;
 122                 }
 123             }
 124
 125             $child->{leaves}{$_} += $node->{leaves}{$_}
 126                 for keys %{ $node->{leaves} };
 127
 128             $child->{_ids_merged} .= ",$node->{id}";
 129             my @child_ids = split /,/, $node->{child_ids};
 130             $child->{child_count} = @child_ids;
 131
 132             $node = $child;
 133         }
 134         elsif ($depth) {
 135             $children = [ map { _fetch_node_tree($_, $depth-1) } @child_ids ];
 136             $node->{children} = $children;
 137             $node->{child_count} = @$children;
 138         }
 139     }
 140     return $node;
 141 }
 142
 143 sub _transform_node_tree {  # recurse depth first
 144     my ($node, $transform) = @_;
 145     if (my $children = $node->{children}) {
 146         $_ = _transform_node_tree($_, $transform) for @$children;
 147     }
 148     return $transform->($node);
 149 }
 150
 151
 152 app->start;
 153 __DATA__
 154 @@ index.html.ep
 155 % layout 'default';
 156 % title 'Welcome';
 157 Welcome to the Mojolicious real-time web framework!
 158
 159 @@ layouts/default.html.ep
 160 <!DOCTYPE html>
 161 <head>
 162 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
 163 <title>Perl Memory Treemap</title>
 164
 165 <!-- CSS Files -->
 166 <link type="text/css" href="css/base.css" rel="stylesheet" />
 167 <link type="text/css" href="css/Treemap.css" rel="stylesheet" />
 168
 169 <!--[if IE]><script language="javascript" type="text/javascript" src="excanvas.js"></script><![endif]-->
 170
 171 <!-- JIT Library File -->
 172 <script language="javascript" type="text/javascript" src="jit.js"></script>
 173 <script language="javascript" type="text/javascript" src="jquery-1.8.1-min.js"></script>
 174
 175 <!-- Example File -->
 176 <script language="javascript" type="text/javascript" src="sprintf.js"></script>
 177 <script language="javascript" type="text/javascript" src="tm.js"></script>
 178 </head>
 179
 180 <body onload="init();">
 181 <div id="container">
 182
 183 <div id="left-container">
 184
 185 <div class="text">
 186 <h4>
 187 Perl Memory TreeMap
 188 </h4>
 189     Click on a node to zoom in.<br /><br />
 190 </div>
 191
 192 <a id="back" href="#" class="theme button white">Go to Parent</a>
 193
 194 <br />
 195 <form name=params>
 196 <label for="logarea">&nbsp;Logarithmic scale
 197 <input type=checkbox id="logarea" name="logarea">
 198 </form>
 199
 200 </div>
 201
 202 <div id="center-container">
 203     <div id="infovis"></div>
 204 </div>
 205
 206 <div id="right-container">
 207
 208 <div id="inner-details"></div>
 209
 210 </div>
 211
 212 <div id="log"></div>
 213 </div>
 214 </body>
 215 </html>