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; # possibly needs v3
  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 Data::Dump qw(pp);
 133         local $jit_tree->{children};
 134         Dwarn(dclone($jit_tree)); # dclone to avoid stringification
 135     }
 136
 137     $self->render_json($jit_tree);
 138 };
 139
 140
 141 sub _fetch_node_tree {
 142     my ($id, $depth) = @_;
 143
 144     warn "#$id fetching\n"
 145         if $opt_debug;
 146     my $node = SizeMe->selectrow_hashref("select * from node where id = ?", undef, $id)
 147         or die "Node '$id' not found"; # shouldn't die
 148     $node->{$_} += 0 for (qw(child_count kids_node_count kids_size self_size));
 149     $node->{leaves} = $j->decode(delete $node->{leaves_json});
 150     $node->{attr}   = $j->decode(delete $node->{attr_json});
 151     $node->{name} .= "->" if $node->{type} == 2 && $node->{name};
 152
 153     if ($node->{child_ids}) {
 154         my @child_ids = split /,/, $node->{child_ids};
 155         my $children;
 156
 157         # if this node has only one child then we merge that child into this node
 158         # this makes the treemap more usable
 159         if (@child_ids == 1
 160             #        && $node->{type} == 2 # only collapse links XXX
 161         ) {
 162             warn "#$id fetch only child $child_ids[0]\n"
 163                 if $opt_debug;
 164             my $child = _fetch_node_tree($child_ids[0], $depth); # same depth
 165             # merge node into child
 166             # XXX id, depth, parent_id
 167             warn "Merged $node->{name} (#$node->{id} d$node->{depth}) with only child $child->{name} #$child->{id}\n"
 168                 if $opt_debug;
 169             $child->{name} = "$node->{name} $child->{name}";
 170             $child->{$_} += $node->{$_} for (qw(self_size));
 171             $child->{$_}  = $node->{$_} for (qw(parent_id));
 172
 173             $child->{title} = join " ", grep { defined && length } $child->{title}, $node->{title};
 174             #warn "Titled $child->{title}" if $child->{title};
 175
 176             # somewhat hackish attribute merging
 177             for my $attr_type (keys %{ $node->{attr} }) {
 178                 my $src = $node->{attr}{$attr_type};
 179                 if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value
 180                     my $dst = $child->{attr}{$attr_type} ||= {};
 181                     for my $k (keys %$src) {
 182                         warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n"
 183                             if defined $dst->{$k};
 184                         $dst->{$k} = $src->{$k};
 185                     }
 186                 }
 187                 elsif (ref $src eq 'ARRAY') { # eg NPattr_PADNAME: {attr}{2}[$val] = $name
 188                     my $dst = $child->{attr}{$attr_type} ||= [];
 189                     my $idx = @$src;
 190                     while (--$idx >= 0) {
 191                         warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n"
 192                             if defined $dst->[$idx];
 193                         $dst->[$idx] = $src->[$idx];
 194                     }
 195                 }
 196                 else { # assume scalar
 197                     warn "Node $child->{id} attr $attr_type=$child->{attr}{$attr_type} overwritten by $src\n"
 198                         if exists $child->{attr}{$attr_type};
 199                     $child->{attr}{$attr_type} = $src;
 200                 }
 201             }
 202
 203             $child->{leaves}{$_} += $node->{leaves}{$_}
 204                 for keys %{ $node->{leaves} };
 205
 206             $child->{_ids_merged} .= ",$node->{id}";
 207             my @child_ids = split /,/, $node->{child_ids};
 208             $child->{child_count} = @child_ids;
 209
 210             $node = $child; # use the merged child as this node
 211         }
 212         if ($depth) { # recurse to required depth
 213             $children = [ map { _fetch_node_tree($_, $depth-1) } @child_ids ];
 214             $node->{children} = $children;
 215             $node->{child_count} = @$children;
 216         }
 217     }
 218     return $node;
 219 }
 220
 221
 222 sub _transform_node_tree {  # recurse depth first
 223     my ($node, $transform) = @_;
 224     if (my $children = $node->{children}) {
 225         $_ = _transform_node_tree($_, $transform) for @$children;
 226     }
 227     return $transform->($node);
 228 }
 229
 230
 231 app->start;
 232
 233 {   # just to reserve the namespace for future use
 234     package Devel::SizeMe::Graph;
 235     1;
 236 }
 237
 238 __DATA__
 239 @@ index.html.ep
 240 % layout 'default';
 241 % title 'Welcome';
 242 Welcome to the Mojolicious real-time web framework!
 243
 244 @@ layouts/default.html.ep
 245 <!DOCTYPE html>
 246 <head>
 247 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
 248 <title>Perl Memory Treemap</title>
 249
 250 <!-- CSS Files -->
 251 <link type="text/css" href="css/base.css" rel="stylesheet" />
 252 <link type="text/css" href="css/Treemap.css" rel="stylesheet" />
 253
 254 <!--[if IE]><script language="javascript" type="text/javascript" src="excanvas.js"></script><![endif]-->
 255
 256 <!-- JIT Library File -->
 257 <script language="javascript" type="text/javascript" src="jit-yc.js"></script>
 258 <script language="javascript" type="text/javascript" src="jquery-1.8.1-min.js"></script>
 259 <script language="javascript" type="text/javascript" src="sprintf.js"></script>
 260 <script language="javascript" type="text/javascript" src="treemap.js"></script>
 261 </head>
 262
 263 <body onload="init();">
 264
 265 <div id="container">
 266
 267 <div id="left-container">
 268
 269 <div class="text">
 270 <h4> Perl Memory TreeMap </h4>
 271     Click on a node to zoom in.<br /><br />
 272 </div>
 273
 274 <a id="back" href="#" class="theme button white">Go to Parent</a>
 275 <br />
 276 <form name=params>
 277 <label for="logarea">&nbsp;Logarithmic scale
 278 <input type=checkbox id="logarea" name="logarea">
 279 </form>
 280
 281 </div>
 282
 283 <div id="center-container">
 284     <div id="infovis"></div>
 285 </div>
 286
 287 <div id="right-container">
 288     <div id="inner-details"></div>
 289 </div>
 290
 291 <div id="log"></div>
 292 </div>
 293 </body>
 294 </html>