bin/sizeme_graph.pl

   1 #!/usr/bin/env perl
   2
   3 BEGIN {
   4     die qq{$0 requires Mojolicious::Lite, which isn't installed.
   5
   6     Currently requires Mojolicious::Lite which isn't available for perl 5.8.
   7     If this affects you you can run Devel::SizeMe with your normal perl and
   8     run sizeme_graph.pl with a different perl, perhaps on a different machine.
   9     \n}
  10         unless eval "require Mojolicious::Lite";
  11 }
  12
  13 =head1 NAME
  14
  15 sizeme_graph.pl - web server providing an interactive treemap of Devel::SizeMe data
  16
  17 =head1 SYNOPSIS
  18
  19     sizeme_graph.pl --db sizeme.db daemon
  20
  21     sizeme_graph.pl daemon # same as above
  22
  23 Then open a web browser on http://127.0.0.1:3000
  24
  25 =head1 DESCRIPTION
  26
  27 Reads a database created by sizeme_store.pl and provides a web interface with
  28 an interactive treemap of the data.
  29
  30 Currently requires Mojolicious::Lite which isn't available for perl 5.8.
  31 If this affects you you can run Devel::SizeMe with your normal perl and
  32 run sizeme_graph.pl with a different perl, perhaps on a different machine.
  33
  34 =head2 TODO
  35
  36 Current implementation is all very alpha and rather hackish.
  37
  38 Split out the db and tree code into a separate module.
  39
  40 Use a history management library so the back button works and we can have
  41 links to specific nodes.
  42
  43 Better tool-tip and/or add a scrollable information area below the treemap
  44 that could contain details and links.
  45
  46 Make the treemap resize to fit the browser window (as NYTProf does).
  47
  48 Protect against nodes with thousands of children
  49     perhaps replace all with single merged child that has no children itself
  50     but just a warning as a title.
  51
  52 Implement other visualizations, such as a space-tree
  53 http://thejit.org/static/v20/Jit/Examples/Spacetree/example2.html
  54
  55 =cut
  56
  57 use strict;
  58 use warnings;
  59
  60 use Mojolicious::Lite;
  61 use JSON::XS;
  62 use Getopt::Long;
  63 use Storable qw(dclone);
  64 use Devel::Dwarn;
  65 use Devel::SizeMe::Graph;
  66
  67 require ORLite;
  68
  69 my $j = JSON::XS->new;
  70
  71 GetOptions(
  72     'db=s' => \(my $opt_db = 'sizeme.db'),
  73     'showid!' => \my $opt_showid,
  74     'debug!' => \my $opt_debug,
  75 ) or exit 1;
  76
  77 die "Can't open $opt_db: $!\n" unless -r $opt_db;
  78 warn "Reading $opt_db\n";
  79
  80 # XXX currently uses ORLite but doesn't actually make use of it in any useful way
  81 ORLite->import({
  82     file => $opt_db,
  83     package => "SizeMe",
  84     readonly => 1,
  85     #user_version => 1, # XXX
  86     #unicode => 1, # XXX
  87 });
  88
  89 my $static_dir = $INC{'Devel/SizeMe/Graph.pm'} or die 'panic';
  90 $static_dir =~ s:\.pm$:/static:;
  91 die "panic $static_dir" unless -d $static_dir;
  92 push @{ app->static->paths}, $static_dir;
  93
  94
  95 # Documentation browser under "/perldoc"
  96 plugin 'PODRenderer';
  97
  98 get '/' => sub {
  99     my $self = shift;
 100     $self->render('index');
 101 };
 102
 103
 104 # /jit_tree are AJAX requests from the treemap visualization
 105 get '/jit_tree/:id/:depth' => sub {
 106     my $self = shift;
 107
 108     my $id = $self->stash('id');
 109     my $depth = $self->stash('depth');
 110
 111     # hack, would be best done on the client side
 112     my $logarea = (defined $self->param('logarea'))
 113         ? $self->param('logarea')
 114         : Mojo::URL->new($self->req->headers->referrer)->query->param('logarea');
 115
 116     my $node_tree = _fetch_node_tree($id, $depth);
 117     my $jit_tree = _transform_node_tree($node_tree, sub {
 118         my ($node) = @_;
 119         my $children = delete $node->{children}; # XXX edits the src tree
 120         my $area = $node->{self_size}+$node->{kids_size};
 121         $node->{'$area'} = ($logarea) ? log($area) : $area; # XXX move to jit js
 122         my $jit_node = {
 123             id   => $node->{id},
 124             name => ($node->{title} || $node->{name}).($opt_showid ? " #$node->{id}" : ""),
 125             data => $node,
 126         };
 127         $jit_node->{children} = $children if $children;
 128         return $jit_node;
 129     });
 130
 131     if(1){ # debug
 132         use Devel::Dwarn;
 133         use Data::Dump qw(pp);
 134         local $jit_tree->{children};
 135         pp(dclone($jit_tree)); # dclone to avoid stringification
 136     }
 137
 138     $self->render_json($jit_tree);
 139 };
 140
 141
 142 sub _fetch_node_tree {
 143     my ($id, $depth) = @_;
 144
 145     warn "#$id fetching\n"
 146         if $opt_debug;
 147     my $node = SizeMe->selectrow_hashref("select * from node where id = ?", undef, $id)
 148         or die "Node '$id' not found"; # shouldn't die
 149     $node->{$_} += 0 for (qw(child_count kids_node_count kids_size self_size));
 150     $node->{leaves} = $j->decode(delete $node->{leaves_json});
 151     $node->{attr}   = $j->decode(delete $node->{attr_json});
 152     $node->{name} .= "->" if $node->{type} == 2 && $node->{name};
 153
 154     if ($node->{child_ids}) {
 155         my @child_ids = split /,/, $node->{child_ids};
 156         my $children;
 157
 158         # if this node has only one child then we merge that child into this node
 159         # this makes the treemap more usable
 160         if (@child_ids == 1
 161             #        && $node->{type} == 2 # only collapse links XXX
 162         ) {
 163             warn "#$id fetch only child $child_ids[0]\n"
 164                 if $opt_debug;
 165             my $child = _fetch_node_tree($child_ids[0], $depth); # same depth
 166             # merge node into child
 167             # XXX id, depth, parent_id
 168             warn "Merged $node->{name} (#$node->{id} d$node->{depth}) with only child $child->{name} #$child->{id}\n"
 169                 if $opt_debug;
 170             $child->{name} = "$node->{name} $child->{name}";
 171             $child->{$_} += $node->{$_} for (qw(self_size));
 172             $child->{$_}  = $node->{$_} for (qw(parent_id));
 173
 174             $child->{title} = join " ", grep { defined && length } $child->{title}, $node->{title};
 175             #warn "Titled $child->{title}" if $child->{title};
 176
 177             # somewhat hackish attribute merging
 178             for my $attr_type (keys %{ $node->{attr} }) {
 179                 my $src = $node->{attr}{$attr_type};
 180                 if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value
 181                     my $dst = $child->{attr}{$attr_type} ||= {};
 182                     for my $k (keys %$src) {
 183                         warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n"
 184                             if defined $dst->{$k};
 185                         $dst->{$k} = $src->{$k};
 186                     }
 187                 }
 188                 elsif (ref $src eq 'ARRAY') { # eg NPattr_PADNAME: {attr}{2}[$val] = $name
 189                     my $dst = $child->{attr}{$attr_type} ||= [];
 190                     my $idx = @$src;
 191                     while (--$idx >= 0) {
 192                         warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n"
 193                             if defined $dst->[$idx];
 194                         $dst->[$idx] = $src->[$idx];
 195                     }
 196                 }
 197                 else { # assume scalar
 198                     warn "Node $child->{id} attr $attr_type=$child->{attr}{$attr_type} overwritten by $src\n"
 199                         if exists $child->{attr}{$attr_type};
 200                     $child->{attr}{$attr_type} = $src;
 201                 }
 202             }
 203
 204             $child->{leaves}{$_} += $node->{leaves}{$_}
 205                 for keys %{ $node->{leaves} };
 206
 207             $child->{_ids_merged} .= ",$node->{id}";
 208             my @child_ids = split /,/, $node->{child_ids};
 209             $child->{child_count} = @child_ids;
 210
 211             $node = $child; # use the merged child as this node
 212         }
 213         if ($depth) { # recurse to required depth
 214             $children = [ map { _fetch_node_tree($_, $depth-1) } @child_ids ];
 215             $node->{children} = $children;
 216             $node->{child_count} = @$children;
 217         }
 218     }
 219     return $node;
 220 }
 221
 222
 223 sub _transform_node_tree {  # recurse depth first
 224     my ($node, $transform) = @_;
 225     if (my $children = $node->{children}) {
 226         $_ = _transform_node_tree($_, $transform) for @$children;
 227     }
 228     return $transform->($node);
 229 }
 230
 231
 232 app->start;
 233
 234 {   # just to reserve the namespace for future use
 235     package Devel::SizeMe::Graph;
 236     1;
 237 }
 238
 239 __DATA__
 240 @@ index.html.ep
 241 % layout 'default';
 242 % title 'Welcome';
 243 Welcome to the Mojolicious real-time web framework!
 244
 245 @@ layouts/default.html.ep
 246 <!DOCTYPE html>
 247 <head>
 248 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
 249 <title>Perl Memory Treemap</title>
 250
 251 <!-- CSS Files -->
 252 <link type="text/css" href="css/base.css" rel="stylesheet" />
 253 <link type="text/css" href="css/Treemap.css" rel="stylesheet" />
 254
 255 <!--[if IE]><script language="javascript" type="text/javascript" src="excanvas.js"></script><![endif]-->
 256
 257 <!-- JIT Library File -->
 258 <script language="javascript" type="text/javascript" src="jit-yc.js"></script>
 259 <script language="javascript" type="text/javascript" src="jquery-1.8.1-min.js"></script>
 260 <script language="javascript" type="text/javascript" src="sprintf.js"></script>
 261 <script language="javascript" type="text/javascript" src="treemap.js"></script>
 262 </head>
 263
 264 <body onload="init();">
 265
 266 <div id="container">
 267
 268 <div id="left-container">
 269
 270 <div class="text">
 271 <h4> Perl Memory TreeMap </h4>
 272     Click on a node to zoom in.<br /><br />
 273 </div>
 274
 275 <a id="back" href="#" class="theme button white">Go to Parent</a>
 276 <br />
 277 <form name=params>
 278 <label for="logarea">&nbsp;Logarithmic scale
 279 <input type=checkbox id="logarea" name="logarea">
 280 </form>
 281
 282 </div>
 283
 284 <div id="center-container">
 285     <div id="infovis"></div>
 286 </div>
 287
 288 <div id="right-container">
 289     <div id="inner-details"></div>
 290 </div>
 291
 292 <div id="log"></div>
 293 </div>
 294 </body>
 295 </html>