9 use Storable qw(dclone);
14 Needs to be run from the static/. directory.
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.
25 Remove ORLite (for now)
27 Make the treemap resize to fit the browser window (as NYTProf does).
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.
36 'db=s' => \(my $opt_db = '../dmemtree.db'),
37 'debug!' => \my $opt_debug,
40 #warn "Reading from $opt_db\n";
42 # XXX currently uses ORLite but doesn't actually make use of it in any useful way
43 # should be removed and replaced with plain DBI till we have an obvious need for it
45 file => '../dmemtree.db',
52 my $j = JSON::XS->new;
54 # Documentation browser under "/perldoc"
59 $self->render('index');
63 # /jit_tree are AJAX requests from the treemap visualization
64 get '/jit_tree/:id/:depth' => sub {
67 my $id = $self->stash('id');
68 my $depth = $self->stash('depth');
70 # hack, would be best done on the client side
71 my $logarea = (defined $self->param('logarea'))
72 ? $self->param('logarea')
73 : Mojo::URL->new($self->req->headers->referrer)->query->param('logarea');
75 my $node_tree = _fetch_node_tree($id, $depth);
76 my $jit_tree = _transform_node_tree($node_tree, sub {
78 my $children = delete $node->{children}; # XXX edits the src tree
79 my $area = $node->{self_size}+$node->{kids_size};
80 $node->{'$area'} = ($logarea) ? log($area) : $area; # XXX move to jit js
83 name => $node->{title} || $node->{name},
86 $jit_node->{children} = $children if $children;
92 use Data::Dump qw(pp);
93 local $jit_tree->{children};
94 pp(dclone($jit_tree)); # dclone to avoid stringification
97 $self->render_json($jit_tree);
101 sub _fetch_node_tree {
102 my ($id, $depth) = @_;
104 my $node = MemView->selectrow_hashref("select * from node where id = ?", undef, $id)
105 or die "Node '$id' not found"; # shouldn't die
106 $node->{$_} += 0 for (qw(child_count kids_node_count kids_size self_size));
107 $node->{leaves} = $j->decode(delete $node->{leaves_json});
108 $node->{attr} = $j->decode(delete $node->{attr_json});
109 $node->{name} .= "->" if $node->{type} == 2 && $node->{name};
111 if ($node->{child_ids}) {
112 my @child_ids = split /,/, $node->{child_ids};
115 # if this node has only one child then we merge that child into this node
116 # this makes the treemap more usable
118 && $node->{type} == 2 # currently we only collapse links XXX
120 my $child = _fetch_node_tree($child_ids[0], $depth); # same depth
121 # merge node into child
122 # XXX id, depth, parent_id
123 warn "Merged $node->{name} #$node->{id} with only child $child->{name} #$child->{id}\n"
125 $child->{name} = "$node->{name} $child->{name}";
126 $child->{$_} += $node->{$_} for (qw(self_size));
127 $child->{$_} = $node->{$_} for (qw(parent_id));
129 $child->{title} = join " ", grep { defined && length } $child->{title}, $node->{title};
130 #warn "Titled $child->{title}" if $child->{title};
132 # somewhat hackish attribute merging
133 for my $attr_type (keys %{ $node->{attr} }) {
134 my $src = $node->{attr}{$attr_type};
135 if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value
136 my $dst = $child->{attr}{$attr_type} ||= {};
137 for my $k (keys %$src) {
138 warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n"
139 if defined $dst->{$k};
140 $dst->{$k} = $src->{$k};
143 elsif (ref $src eq 'ARRAY') { # eg NPattr_PADNAME: {attr}{2}[$val] = $name
144 my $dst = $child->{attr}{$attr_type} ||= [];
146 while (--$idx >= 0) {
147 warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n"
148 if defined $dst->[$idx];
149 $dst->[$idx] = $src->[$idx];
152 else { # assume scalar
153 warn "Node $child->{id} attr $attr_type=$child->{attr}{$attr_type} overwritten by $src\n"
154 if exists $child->{attr}{$attr_type};
155 $child->{attr}{$attr_type} = $src;
159 $child->{leaves}{$_} += $node->{leaves}{$_}
160 for keys %{ $node->{leaves} };
162 $child->{_ids_merged} .= ",$node->{id}";
163 my @child_ids = split /,/, $node->{child_ids};
164 $child->{child_count} = @child_ids;
166 $node = $child; # use the merged child as this node
168 # XXX this elsif() should possibly be a plain if(), maybe with tweaks to the above
169 # because we want to allow the recursion
170 elsif ($depth) { # recurse to required depth
171 $children = [ map { _fetch_node_tree($_, $depth-1) } @child_ids ];
172 $node->{children} = $children;
173 $node->{child_count} = @$children;
180 sub _transform_node_tree { # recurse depth first
181 my ($node, $transform) = @_;
182 if (my $children = $node->{children}) {
183 $_ = _transform_node_tree($_, $transform) for @$children;
185 return $transform->($node);
195 Welcome to the Mojolicious real-time web framework!
197 @@ layouts/default.html.ep
200 <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" />
201 <title>Perl Memory Treemap</title>
204 <link type="text/css" href="css/base.css" rel="stylesheet" />
205 <link type="text/css" href="css/Treemap.css" rel="stylesheet" />
207 <!--[if IE]><script language="javascript" type="text/javascript" src="excanvas.js"></script><![endif]-->
209 <!-- JIT Library File -->
210 <script language="javascript" type="text/javascript" src="jit.js"></script>
211 <script language="javascript" type="text/javascript" src="jquery-1.8.1-min.js"></script>
213 <script language="javascript" type="text/javascript" src="sprintf.js"></script>
214 <script language="javascript" type="text/javascript" src="dmemtreemap.js"></script>
217 <body onload="init();">
220 <div id="left-container">
226 Click on a node to zoom in.<br /><br />
229 <a id="back" href="#" class="theme button white">Go to Parent</a>
233 <label for="logarea"> Logarithmic scale
234 <input type=checkbox id="logarea" name="logarea">
239 <div id="center-container">
240 <div id="infovis"></div>
243 <div id="right-container">
245 <div id="inner-details"></div>