Commit | Line | Data |
b2fc39a5 |
1 | #!/usr/bin/env perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
f60f09e5 |
6 | use JSON::XS; |
b2fc39a5 |
7 | use Mojolicious::Lite; |
e8f4c506 |
8 | use Getopt::Long; |
9 | |
10 | GetOptions( |
11 | 'db=s' => \(my $opt_db = '../x.db'), |
12 | ) or exit 1; |
b2fc39a5 |
13 | |
14 | use ORLite { |
15 | file => '../x.db', |
16 | package => "MemView", |
17 | #user_version => 1, |
18 | readonly => 1, |
19 | #unicode => 1, |
20 | }; |
21 | |
f60f09e5 |
22 | my $j = JSON::XS->new; |
23 | |
b2fc39a5 |
24 | # Documentation browser under "/perldoc" |
25 | plugin 'PODRenderer'; |
26 | |
27 | get '/' => sub { |
28 | my $self = shift; |
29 | $self->render('index'); |
30 | }; |
31 | |
32 | get '/jit_tree/:id/:depth' => sub { |
33 | my $self = shift; |
e8f4c506 |
34 | my $logarea = $self->param('logarea'); |
35 | |
b2fc39a5 |
36 | my $id = $self->stash('id'); |
37 | my $depth = $self->stash('depth'); |
38 | warn "jit_tree $id $depth"; |
875c1073 |
39 | my $node_tree = _fetch_node_tree($id, $depth); |
40 | my $jit_tree = _transform_node_tree($node_tree, sub { |
41 | my ($node) = @_; |
42 | my $children = delete $node->{children}; # XXX edits the src tree |
e8f4c506 |
43 | my $area = $node->{self_size}+$node->{kids_size}; |
44 | $node->{'$area'} = ($logarea) ? log($area) : $area; |
bb66f8a1 |
45 | my $jit_node = { |
46 | id => $node->{id}, |
e8f4c506 |
47 | name => $node->{title} || $node->{name}, |
bb66f8a1 |
48 | data => $node, |
49 | }; |
50 | $jit_node->{children} = $children if $children; |
51 | return $jit_node; |
b2fc39a5 |
52 | }); |
bb66f8a1 |
53 | if(1){ |
54 | use Devel::Dwarn; |
55 | use Data::Dump qw(pp); |
f9d8678b |
56 | local $jit_tree->{children}; |
bb66f8a1 |
57 | pp($jit_tree); |
58 | } |
b2fc39a5 |
59 | $self->render_json($jit_tree); |
60 | }; |
61 | |
875c1073 |
62 | sub _fetch_node_tree { |
63 | my ($id, $depth) = @_; |
64 | my $node = MemView->selectrow_hashref("select * from node where id = ?", undef, $id) |
65 | or die "Node '$id' not found"; |
e78b28ca |
66 | $node->{leaves} = $j->decode(delete $node->{leaves_json}); |
e8f4c506 |
67 | $node->{attr} = $j->decode(delete $node->{attr_json}); |
e78b28ca |
68 | |
5a78486c |
69 | if ($node->{child_ids}) { |
70 | my @child_ids = split /,/, $node->{child_ids}; |
875c1073 |
71 | my $children; |
5a78486c |
72 | if (@child_ids == 1) { |
73 | my $child = _fetch_node_tree($child_ids[0], $depth); # same depth |
f9d8678b |
74 | # merge node into child |
5a78486c |
75 | # XXX id, depth, parent_id |
f9d8678b |
76 | warn "Merged $node->{name} #$node->{id} with only child $child->{name} #$child->{id}\n"; |
77 | $child->{name} = "$node->{name} + $child->{name}"; |
78 | $child->{$_} += $node->{$_} for (qw(self_size)); |
5a78486c |
79 | $child->{$_} = $node->{$_} for (qw(parent_id)); |
e8f4c506 |
80 | |
81 | $child->{title} = join " + ", grep { defined && length } $child->{title}, $node->{title}; |
82 | warn "Titled $child->{title}" if $child->{title}; |
83 | |
84 | for my $attr_type (keys %{ $node->{attr} }) { |
85 | my $src = $node->{attr}{$attr_type}; |
86 | if (ref $src eq 'HASH') { # eg NPattr_NAME: {attr}{1}{$name} = $value |
87 | my $dst = $child->{attr}{$attr_type} ||= {}; |
88 | for my $k (keys %$src) { |
89 | warn "Node $child->{id} attr $attr_type:$k=$dst->{$k} overwritten by $src->{$k}\n" |
90 | if defined $dst->{$k}; |
91 | $dst->{$k} = $src->{$k}; |
92 | } |
93 | } |
94 | else { # ARRAY eg NPattr_PADNAME: {attr}{2}[$val] = $name |
95 | my $dst = $child->{attr}{$attr_type} ||= []; |
96 | my $idx = @$src; |
97 | while (--$idx >= 0) { |
98 | warn "Node $child->{id} attr $attr_type:$idx=$dst->[$idx] overwritten by $src->[$idx]\n" |
99 | if defined $dst->[$idx]; |
100 | $dst->[$idx] = $src->[$idx]; |
101 | } |
102 | } |
103 | } |
104 | |
e78b28ca |
105 | $child->{leaves}{$_} += $node->{leaves}{$_} |
106 | for keys %{ $node->{leaves} }; |
5a78486c |
107 | |
108 | $child->{_ids_merged} .= ",$node->{id}"; |
109 | my @child_ids = split /,/, $node->{child_ids}; |
110 | $child->{child_count} = @child_ids; |
111 | |
f9d8678b |
112 | $node = $child; |
875c1073 |
113 | } |
f9d8678b |
114 | elsif ($depth) { |
5a78486c |
115 | $children = [ map { _fetch_node_tree($_, $depth-1) } @child_ids ]; |
f9d8678b |
116 | $node->{children} = $children; |
117 | $node->{child_count} = @$children; |
875c1073 |
118 | } |
b2fc39a5 |
119 | } |
b2fc39a5 |
120 | return $node; |
121 | } |
122 | |
f9d8678b |
123 | sub _transform_node_tree { # recurse depth first |
875c1073 |
124 | my ($node, $transform) = @_; |
125 | if (my $children = $node->{children}) { |
126 | $_ = _transform_node_tree($_, $transform) for @$children; |
127 | } |
128 | return $transform->($node); |
129 | } |
130 | |
b2fc39a5 |
131 | |
132 | app->start; |
133 | __DATA__ |
134 | @@ index.html.ep |
135 | % layout 'default'; |
136 | % title 'Welcome'; |
137 | Welcome to the Mojolicious real-time web framework! |
138 | |
139 | @@ layouts/default.html.ep |
140 | <!DOCTYPE html> |
141 | <head> |
142 | <meta http-equiv="Content-Type" content="text/html; charset=UTF-8" /> |
bb66f8a1 |
143 | <title>Perl Memory Treemap</title> |
b2fc39a5 |
144 | |
145 | <!-- CSS Files --> |
146 | <link type="text/css" href="css/base.css" rel="stylesheet" /> |
147 | <link type="text/css" href="css/Treemap.css" rel="stylesheet" /> |
148 | |
149 | <!--[if IE]><script language="javascript" type="text/javascript" src="excanvas.js"></script><![endif]--> |
150 | |
151 | <!-- JIT Library File --> |
152 | <script language="javascript" type="text/javascript" src="jit.js"></script> |
153 | <script language="javascript" type="text/javascript" src="//ajax.googleapis.com/ajax/libs/jquery/1.8.1/jquery.min.js"></script> |
154 | |
155 | <!-- Example File --> |
bb66f8a1 |
156 | <script language="javascript" type="text/javascript" src="sprintf.js"></script> |
b2fc39a5 |
157 | <script language="javascript" type="text/javascript" src="tm.js"></script> |
158 | </head> |
159 | |
160 | <body onload="init();"> |
161 | <div id="container"> |
162 | |
163 | <div id="left-container"> |
164 | |
b2fc39a5 |
165 | <div class="text"> |
166 | <h4> |
bb66f8a1 |
167 | Perl Memory TreeMap |
b2fc39a5 |
168 | </h4> |
bb66f8a1 |
169 | Clicking on a node will show a new TreeMap with the contents of that node.<br /><br /> |
b2fc39a5 |
170 | </div> |
171 | |
172 | <a id="back" href="#" class="theme button white">Go to Parent</a> |
e8f4c506 |
173 | |
174 | <br /> |
175 | <form name=params> |
176 | <label for="logarea"> Logarithmic scale |
177 | <input type=checkbox id="logarea" name="logarea"> |
178 | </form> |
179 | |
b2fc39a5 |
180 | </div> |
181 | |
182 | <div id="center-container"> |
183 | <div id="infovis"></div> |
184 | </div> |
185 | |
186 | <div id="right-container"> |
187 | |
188 | <div id="inner-details"></div> |
189 | |
190 | </div> |
191 | |
192 | <div id="log"></div> |
193 | </div> |
194 | </body> |
195 | </html> |