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