static/sizeme_graph.pl

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Mojolicious::Lite;
   7 use JSON::XS;
   8 use Getopt::Long;
   9 use Storable qw(dclone);
  10 use Devel::Dwarn;
  11
  12 =pod NOTE
  13
  14     Needs to be run from the static/. directory.
  15     For example:
  16
  17         ./sizeme_graph.pl daemon
  18
  19 =pod TODO
  20
  21     Move all the static files into the DATA section of ths script so the script
  22     is entirely self-contained and doesn't need any static files installed.
  23     Or, work out how to install the static files and reference them from the script.
  24
  25     Remove ORLite (for now)
  26
  27     Make the treemap resize to fit the browser window (as NYTProf does).
  28
  29     Protect against nodes with thousands of children
  30         perhaps replace all with single merged child that has no children itself
  31         but just a warning as a title.
  32
  33 =cut
  34
  35 GetOptions(
  36     'db=s' => \(my $opt_db = '../sizeme.db'),
  37     'debug!' => \my $opt_debug,
  38 ) or exit 1;
  39
  40 #warn "Reading from $opt_db\n";
  41
  42 # XXX currently uses ORLite but doesn't actually make use of it in any useful way
  43 # should be removed and replaced with plain DBI till we have an obvious need for it
  44 use ORLite {
  45     file => '../sizeme.db',
  46     package => "MemView",
  47     #user_version => 1,
  48     readonly => 1,
  49     #unicode => 1,
  50 };
  51
  52 my $j = JSON::XS->new;
  53
  54 # Documentation browser under "/perldoc"
  55 plugin 'PODRenderer';
  56
  57 get '/' => sub {
  58     my $self = shift;
  59     $self->render('index');
  60 };
  61
  62
  63 # /jit_tree are AJAX requests from the treemap visualization
  64 get '/jit_tree/:id/:depth' => sub {
  65     my $self = shift;
  66
  67     my $id = $self->stash('id');
  68     my $depth = $self->stash('depth');
  69
  70     # hack, would be best done on the client side
  71     my $logarea = (defined $self->param('logarea'))
  72         ? $self->param('logarea')
  73         : Mojo::URL->new($self->req->headers->referrer)->query->param('logarea');
  74
  75     my $node_tree = _fetch_node_tree($id, $depth);
  76     my $jit_tree = _transform_node_tree($node_tree, sub {
  77         my ($node) = @_;
  78         my $children = delete $node->{children}; # XXX edits the src tree
  79         my $area = $node->{self_size}+$node->{kids_size};
  80         $node->{'$area'} = ($logarea) ? log($area) : $area; # XXX move to jit js
  81         my $jit_node = {
  82             id   => $node->{id},
  83             name => $node->{title} || $node->{name},
  84             data => $node,
  85         };
  86         $jit_node->{children} = $children if $children;
  87         return $jit_node;
  88     });
  89
  90     if(1){ # debug
  91         use Devel::Dwarn;
  92         use Data::Dump qw(pp);
  93         local $jit_tree->{children};
  94         pp(dclone($jit_tree)); # dclone to avoid stringification
  95     }
  96
  97     $self->render_json($jit_tree);
  98 };
  99
 100
 101 sub _fetch_node_tree {
 102     my ($id, $depth) = @_;
 103
 104     my $node = MemView->selectrow_hashref("select * from node where id = ?", undef, $id)
 105         or die "Node '$id' not found"; # shouldn't die
 106     $node->{$_} += 0 for (qw(child_count kids_node_count kids_size self_size));
 107     $node->{leaves} = $j->decode(delete $node->{leaves_json});
 108     $node->{attr}   = $j->decode(delete $node->{attr_json});
 109     $node->{name} .= "->" if $node->{type} == 2 && $node->{name};
 110
 111     if ($node->{child_ids}) {
 112         my @child_ids = split /,/, $node->{child_ids};
 113         my $children;
 114
 115         # if this node has only one child then we merge that child into this node
 116         # this makes the treemap more usable
 117         if (@child_ids == 1
 118             && $node->{type} == 2 # currently we only collapse links XXX
 119         ) {
 120             my $child = _fetch_node_tree($child_ids[0], $depth); # same depth
 121             # merge node into child
 122             # XXX id, depth, parent_id
 123             warn "Merged $node->{name} #$node->{id} with only child $child->{name} #$child->{id}\n"
 124                 if $opt_debug;
 125             $child->{name} = "$node->{name} $child->{name}";
 126             $child->{$_} += $node->{$_} for (qw(self_size));
 127             $child->{$_}  = $node->{$_} for (qw(parent_id));
 128
 129             $child->{title} = join " ", grep { defined && length } $child->{title}, $node->{title};
 130             #warn "Titled $child->{title}" if $child->{title};
 131
 132             # somewhat hackish attribute merging
 133             for my $attr_type (keys %{ $node->{attr} }) {
 134                 my $src = $node->{attr}{$attr_type};
 135                 if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value
 136                     my $dst = $child->{attr}{$attr_type} ||= {};
 137                     for my $k (keys %$src) {
 138                         warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n"
 139                             if defined $dst->{$k};
 140                         $dst->{$k} = $src->{$k};
 141                     }
 142                 }
 143                 elsif (ref $src eq 'ARRAY') { # eg NPattr_PADNAME: {attr}{2}[$val] = $name
 144                     my $dst = $child->{attr}{$attr_type} ||= [];
 145                     my $idx = @$src;
 146                     while (--$idx >= 0) {
 147                         warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n"
 148                             if defined $dst->[$idx];
 149                         $dst->[$idx] = $src->[$idx];
 150                     }
 151                 }
 152                 else { # assume scalar
 153                     warn "Node $child->{id} attr $attr_type=$child->{attr}{$attr_type} overwritten by $src\n"
 154                         if exists $child->{attr}{$attr_type};
 155                     $child->{attr}{$attr_type} = $src;
 156                 }
 157             }
 158
 159             $child->{leaves}{$_} += $node->{leaves}{$_}
 160                 for keys %{ $node->{leaves} };
 161
 162             $child->{_ids_merged} .= ",$node->{id}";
 163             my @child_ids = split /,/, $node->{child_ids};
 164             $child->{child_count} = @child_ids;
 165
 166             $node = $child; # use the merged child as this node
 167         }
 168         # XXX this elsif() should possibly be a plain if(), maybe with tweaks to the above
 169         # because we want to allow the recursion
 170         elsif ($depth) { # recurse to required depth
 171             $children = [ map { _fetch_node_tree($_, $depth-1) } @child_ids ];
 172             $node->{children} = $children;
 173             $node->{child_count} = @$children;
 174         }
 175     }
 176     return $node;
 177 }
 178
 179
 180 sub _transform_node_tree {  # recurse depth first
 181     my ($node, $transform) = @_;
 182     if (my $children = $node->{children}) {
 183         $_ = _transform_node_tree($_, $transform) for @$children;
 184     }
 185     return $transform->($node);
 186 }
 187
 188
 189 app->start;
 190
 191 __DATA__
 192 @@ index.html.ep
 193 % layout 'default';
 194 % title 'Welcome';
 195 Welcome to the Mojolicious real-time web framework!
 196
 197 @@ layouts/default.html.ep
 198 <!DOCTYPE html>
 199 <head>
 200 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
 201 <title>Perl Memory Treemap</title>
 202
 203 <!-- CSS Files -->
 204 <link type="text/css" href="css/base.css" rel="stylesheet" />
 205 <link type="text/css" href="css/Treemap.css" rel="stylesheet" />
 206
 207 <!--[if IE]><script language="javascript" type="text/javascript" src="excanvas.js"></script><![endif]-->
 208
 209 <!-- JIT Library File -->
 210 <script language="javascript" type="text/javascript" src="jit-yc.js"></script>
 211 <script language="javascript" type="text/javascript" src="jquery-1.8.1-min.js"></script>
 212
 213 <script language="javascript" type="text/javascript" src="sprintf.js"></script>
 214 <script language="javascript" type="text/javascript" src="treemap.js"></script>
 215 </head>
 216
 217 <body onload="init();">
 218 <div id="container">
 219
 220 <div id="left-container">
 221
 222 <div class="text">
 223 <h4>
 224 Perl Memory TreeMap
 225 </h4>
 226     Click on a node to zoom in.<br /><br />
 227 </div>
 228
 229 <a id="back" href="#" class="theme button white">Go to Parent</a>
 230
 231 <br />
 232 <form name=params>
 233 <label for="logarea">&nbsp;Logarithmic scale
 234 <input type=checkbox id="logarea" name="logarea">
 235 </form>
 236
 237 </div>
 238
 239 <div id="center-container">
 240     <div id="infovis"></div>
 241 </div>
 242
 243 <div id="right-container">
 244
 245 <div id="inner-details"></div>
 246
 247 </div>
 248
 249 <div id="log"></div>
 250 </div>
 251 </body>
 252 </html>