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