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