5 sizeme_store.pl - process and store the raw data stream from Devel::SizeMe
9 sizeme_store.pl [--text] [--dot=sizeme.dot] [--db=sizeme.db]
11 Typically used with Devel::SizeMe via the C<SIZEME> env var:
13 export SIZEME='|./sizeme_store.pl --text'
14 export SIZEME='|./sizeme_store.pl --dot=sizeme.dot'
15 export SIZEME='|./sizeme_store.pl --db=sizeme.db'
19 Reads the raw memory data from Devel::SizeMe and processes the tree
20 via a stack, propagating data such as totals, up the tree nodes
21 as the data streams through. Output completed nodes in the request formats.
23 The --text output is similar to the textual representation output by the module
24 when the SIZEME env var is set to an empty string.
26 The --dot output is suitable for feeding to Graphviz. (On OSX the Graphviz
27 application will be started automatically.)
29 The --db output is a SQLite database. The db schema is very subject to change.
30 This output is destined to be the primary one. The other output types will
31 probably become separate programs that read the db.
35 Current implementation is all very alpha and rather hackish.
37 Refactor to separate the core code into a module.
39 Move the output formats into separate modules, which should probably read from
40 the db so the db becomes the canonical source of data.
42 Import constants from XS.
46 # Needs to be generalized to support pluggable output formats.
47 # Actually it needs to be split so sizeme_store.pl only does the store
48 # and another program drives the output with plugins.
49 # Making nodes into (lightweight fast) objects would be smart.
50 # Tests would be even smarter!
52 # When working on this code it's important to have a sense of the flow.
53 # Specifically the way that depth drives the completion of nodes.
54 # It's a depth-first stream processing machine, which only ever holds
55 # a single stack of the currently incomplete nodes, which is always the same as
56 # the current depth. I.e., when a node of depth N arrives, all nodes >N are
57 # popped off the stack and 'completed', each rippling data up to its parent.
63 use DBI qw(looks_like_number);
67 use HTML::Entities qw(encode_entities);;
70 use Carp qw(carp croak confess);
72 # XXX import these from the XS code
73 use constant NPtype_NAME => 0x01;
74 use constant NPtype_LINK => 0x02;
75 use constant NPtype_SV => 0x03;
76 use constant NPtype_MAGIC => 0x04;
77 use constant NPtype_OP => 0x05;
79 use constant NPattr_LEAFSIZE => 0x00;
80 use constant NPattr_NAME => 0x01;
81 use constant NPattr_PADFAKE => 0x02;
82 use constant NPattr_PADNAME => 0x03;
83 use constant NPattr_PADTMP => 0x04;
84 use constant NPattr_NOTE => 0x05;
85 use constant NPattr_PRE_ATTR => 0x06;
86 my @attr_type_name = (qw(size NAME PADFAKE my PADTMP NOTE PREATTR)); # XXX get from XS in some way
90 'text!' => \my $opt_text,
91 'dot=s' => \my $opt_dot,
92 'db=s' => \my $opt_db,
93 'verbose|v!' => \my $opt_verbose,
94 'debug|d!' => \my $opt_debug,
95 'showid!' => \my $opt_showid,
102 my $j = JSON::XS->new->ascii->pretty(0);
104 my ($dbh, $node_ins_sth);
106 $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
107 RaiseError => 1, PrintError => 0, AutoCommit => 0
109 $dbh->do("PRAGMA synchronous = OFF");
116 my $name = encode_entities(shift);
118 return '"'.$name.'"';
126 my $kb = $size / 1024;
127 return $size if $kb < 5;
128 return sprintf "%.1fKb", $kb if $kb < 1000;
129 return sprintf "%.1fMb", $kb/1024;
135 warn ">> enter_node $x->{id}\n" if $opt_debug;
137 my $parent = $stack[-1];
140 if ($x->{name} eq 'AVelem' and $parent->{name} eq 'SV(PVAV)') {
141 my $index = $x->{attr}{+NPattr_NOTE}{i};
144 # If node is an AVelem of a CvPADLIST propagate pad name to AVelem
145 if (@stack >= 4 and (my $cvpl = $stack[-4])->{name} eq 'CvPADLIST') {
146 my $padnames = $cvpl->{_cached}{padnames} ||= do {
147 my @names = @{ $cvpl->{attr}{+NPattr_PADNAME} || []};
148 $_ = "my(".($_||'').")" for @names;
152 $x->{name} = (defined $index and $padnames->[$index]) || "?";
153 $x->{name} =~ s/my\(SVs_PADTMP\)/PADTMP/; # XXX hack for neatness
156 $x->{name} = "[$index]" if defined $index;
168 confess unless defined $x->{id};
169 warn "<< leave_node $x->{id}\n" if $opt_debug;
170 delete $seqn2node{$x->{id}};
172 my $self_size = 0; $self_size += $_ for values %{$x->{leaves}};
173 $x->{self_size} = $self_size;
175 if ($x->{name} eq 'AVelem') {
176 my $index = $x->{attr}{+NPattr_NOTE}{i};
177 $x->{name} = "[$index]" if defined $index;
180 my $parent = $stack[-1];
183 $x->{parent_id} = $parent->{id};
184 # accumulate into parent
185 $parent->{kids_node_count} += 1 + ($x->{kids_node_count}||0);
186 $parent->{kids_size} += $self_size + $x->{kids_size};
187 push @{$parent->{child_id}}, $x->{id};
190 $x->{kids_node_count} ||= 0;
196 printf "// n%d parent=%s(type=%s)\n", $x->{id},
197 $parent ? $parent->{id} : "",
198 $parent ? $parent->{type} : ""
201 if ($x->{type} != NPtype_LINK) {
202 my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
204 if ($x->{kids_size}) {
205 $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
208 $name .= sprintf " +%s", fmt_size($x->{self_size});
210 $name .= " #$x->{id}" if $opt_showid;
213 sprintf("label=%s", $dotnode->($name)),
216 printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
219 my @kids = @{$x->{child_id}||[]};
220 die "panic: NPtype_LINK has more than one child: @kids"
222 for my $child_id (@kids) { # wouldn't work right, eg id= attr
224 my @link_attr = ("id=$x->{id}");
225 (my $link_name = $x->{name}) =~ s/->$//;
226 $link_name .= " #$x->{id}" if $opt_showid;
227 push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
228 printf $dot_fh qq{n%d -> n%d [%s];\n},
229 $x->{parent_id}, $child_id, join(",", @link_attr);
235 my $attr_json = $j->encode($x->{attr});
236 my $leaves_json = $j->encode($x->{leaves});
237 $node_ins_sth->execute(
238 $x->{id}, $x->{name}, $x->{title}, $x->{type}, $x->{depth}, $x->{parent_id},
239 $x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
240 $x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
241 $attr_json, $leaves_json,
252 warn "\t\t\t\t== $_" if $opt_debug;
255 my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
257 if ($type =~ s/^-//) { # Node type ($val is depth)
259 printf "%s%s%s %s [#%d @%d]\n", $indent x $val, $name,
260 ($type == NPtype_LINK) ? "->" : "",
261 $extra||'', $id, $val
264 # this is the core driving logic
265 while ($val < @stack) {
266 my $x = leave_node(pop @stack);
267 warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
270 die "panic: stack already has item at depth $val"
272 die "Depth out of sync\n" if $val != @stack;
273 my $node = enter_node({
274 id => $id, type => $type, name => $name, extra => $extra,
275 attr => { }, leaves => {}, depth => $val, self_size=>0, kids_size=>0
277 $stack[$val] = $node;
278 $seqn2node{$id} = $node;
281 # --- Leaf name and memory size
282 elsif ($type eq "L") {
283 my $node = $seqn2node{$id} || die;
284 $node->{leaves}{$name} += $val;
286 printf "%s+%d=%d %s\n", $indent x ($node->{depth}+1), $val, $run_size, $name
290 # --- Attribute type, name and value (all rather hackish)
291 elsif (looks_like_number($type)) {
292 my $node = $seqn2node{$id} || die;
293 my $attr = $node->{attr} || die;
295 # attributes where the string is a key (or always empty and the type is the key)
296 if ($type == NPattr_NAME or $type == NPattr_NOTE) {
297 printf "%s~%s(%s) %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
299 warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
300 if exists $attr->{$type}{$name};
301 $attr->{$type}{$name} = $val;
303 $node->{title} = $name if $type == NPattr_NAME and !$val; # XXX hack
305 # attributes where the number is a key (or always zero)
306 elsif (NPattr_PADFAKE==$type or NPattr_PADTMP==$type or NPattr_PADNAME==$type) {
307 printf "%s~%s('%s') %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
309 warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
310 if defined $attr->{$type}[$val];
311 $attr->{+NPattr_PADNAME}[$val] = $name; # store all as NPattr_PADNAME
314 printf "%s~%s %d [t%d]\n", $indent x ($node->{depth}+1), $name, $val, $type
316 warn "Invalid attribute type '$type' on line $. ($_)";
319 elsif ($type eq 'S') { # start of a run
320 die "Unexpected start token" if @stack;
322 open $dot_fh, ">$opt_dot";
323 print $dot_fh "digraph {\n"; # }
324 print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
327 # XXX add a size_run table records each run
328 # XXX pick a table name to store the run nodes in
329 #$run_ins_sth->execute(
331 $dbh->do("DROP TABLE IF EXISTS $table");
333 CREATE TABLE $table (
334 id integer primary key,
343 kids_node_count integer,
349 $node_ins_sth = $dbh->prepare(qq{
350 INSERT INTO $table VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
354 elsif ($type eq 'E') { # end of a run
356 my $top = $stack[0]; # grab top node before we pop all the nodes
357 leave_node(pop @stack) while @stack;
359 # if nothing output (ie size(undef))
360 $top ||= { self_size=>0, kids_size=>0, kids_node_count=>0 };
362 my $top_size = $top->{self_size}+$top->{kids_size};
364 printf "Stored %d nodes totalling %s [lines=%d size=%d write=%.2fs]\n",
365 1+$top->{kids_node_count}, fmt_size($top_size),
367 # the duration here ($val) is from Devel::SizeMe perspective
368 # ie doesn't include time to read file/pipe and commit to database.
370 if ($opt_verbose or $run_size != $top_size) {
371 warn "EOF ends $top->{id} d$top->{depth}: size $top->{self_size}+$top->{kids_size}\n";
374 die "panic: seqn2node should be empty ". Dumper(\%seqn2node)
380 system("open -a Graphviz $opt_dot") if $^O eq 'darwin'; # OSX
383 $dbh->commit if $dbh;
386 warn "Invalid type '$type' on line $. ($_)";
390 $dbh->commit if $dbh and $id % 10_000 == 0;
392 die "EOF without end token" if @stack;
395 =for This is out of date but gives you an idea of the data and stream
397 SV(PVAV) fill=1/1 [#1 @0]
404 : : : : SV(PVAV) fill=-1/-1 [#5 @4]
405 : : : : : +64 sv =168
412 N 1 0 SV(PVAV) fill=1/1
419 N 5 4 SV(PVAV) fill=-1/-1