-#!/bin/env perl
+#!/usr/bin/env perl
use strict;
use warnings;
+use autodie;
use DBI qw(looks_like_number);
use DBD::SQLite;
use JSON::XS;
+use Devel::Dwarn;
use Getopt::Long;
+# XXX import these from the XS code
+use constant NPtype_NAME => 0x01;
+use constant NPtype_LINK => 0x02;
+use constant NPtype_SV => 0x03;
+use constant NPtype_MAGIC => 0x04;
+use constant NPtype_OP => 0x05;
+
+use constant NPattr_LEAFSIZE => 0x00;
+use constant NPattr_NAME => 0x01;
+use constant NPattr_PADFAKE => 0x02;
+use constant NPattr_PADNAME => 0x03;
+use constant NPattr_PADTMP => 0x04;
+use constant NPattr_NOTE => 0x05;
+use constant NPattr_PRE_ATTR => 0x06;
+
+
GetOptions(
- 'json!' => \my $opt_json,
- 'dot!' => \my $opt_dot,
+ 'text!' => \my $opt_text,
+ 'dot=s' => \my $opt_dot,
'db=s' => \my $opt_db,
'verbose|v!' => \my $opt_verbose,
'debug|d!' => \my $opt_debug,
+ 'showid!' => \my $opt_showid,
) or exit 1;
my $j = JSON::XS->new->ascii->pretty(0);
-my $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
- RaiseError => 1, PrintError => 0, AutoCommit => 0
-});
-$dbh->do("PRAGMA synchronous = OFF");
-$dbh->do("DROP TABLE IF EXISTS node");
-$dbh->do(q{
- CREATE TABLE node (
- id integer primary key,
- name text,
- title text,
- depth integer,
- parent_id integer,
-
- self_size integer,
- kids_size integer,
- kids_node_count integer,
- child_ids text,
- attr_json text,
- leaves_json text
- )
-});
-my $node_ins_sth = $dbh->prepare(q{
- INSERT INTO node VALUES (?,?,?,?,?, ?,?,?,?,?,?)
-});
+my ($dbh, $node_ins_sth);
+if ($opt_db) {
+ $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
+ RaiseError => 1, PrintError => 0, AutoCommit => 0
+ });
+ $dbh->do("PRAGMA synchronous = OFF");
+ $dbh->do("DROP TABLE IF EXISTS node");
+ $dbh->do(q{
+ CREATE TABLE node (
+ id integer primary key,
+ name text,
+ title text,
+ type integer,
+ depth integer,
+ parent_id integer,
+
+ self_size integer,
+ kids_size integer,
+ kids_node_count integer,
+ child_ids text,
+ attr_json text,
+ leaves_json text
+ )
+ });
+ $node_ins_sth = $dbh->prepare(q{
+ INSERT INTO node VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
+ });
+}
my @stack;
my %seqn2node;
- my $dotnode = sub {
- my $name = shift;
- $name =~ s/"/\\"/g;
- return '"'.$name.'"';
- };
+use HTML::Entities qw(encode_entities);;
+my $dotnode = sub {
+ my $name = encode_entities(shift);
+ $name =~ s/"/\\"/g;
+ return '"'.$name.'"';
+};
-print "memnodes = [" if $opt_json;
+my $dot_fh;
if ($opt_dot) {
- print "digraph {\n"; # }
- print "graph [overlap=false]\n"; # target="???", URL="???"
+ open $dot_fh, ">$opt_dot";
+ print $dot_fh "digraph {\n"; # }
+ print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
+}
+
+sub fmt_size {
+ my $size = shift;
+ my $kb = $size / 1024;
+ return $size if $kb < 5;
+ return sprintf "%.1fKb", $kb if $kb < 1000;
+ return sprintf "%.1fMb", $kb/1024;
}
sub enter_node {
my $x = shift;
- if ($opt_json) {
- print " " x $x->{depth};
- print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
- }
- if ($opt_dot) {
- #printf $fh qq{\tn%d [ %s ]\n}, $x->{id}, $dotnode->($x->{name});
- #print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
+
+ my $parent = $stack[-1];
+ if ($parent) {
+
+ if ($x->{name} eq 'AVelem' and $parent->{name} eq 'SV(PVAV)') {
+ my $index = $x->{attr}{index};
+ # If node is an AVelem of a CvPADLIST propagate pad name to AVelem
+ if (@stack >= 4 and (my $cvpl = $stack[-4])->{name} eq 'CvPADLIST') {
+ # cache the pad names so we can eat them in order
+ my $padnames = $cvpl->{_cached}{padnames} ||= do {
+ my @names = @{ $cvpl->{attr}{+NPattr_PADNAME} || []};
+ $_ = "my(".($_||'').")" for @names;
+ $names[0] = '@_';
+ \@names;
+ };
+ #die Dwarn $x;
+ $x->{name} = $padnames->[$index] || "?";
+ $x->{name} =~ s/my\(SVs_PADTMP\)/PADTMP/; # XXX hack for neatness
+ }
+ else {
+ $x->{name} = "[$index]";
+ }
+ }
}
- return;
+
+ return $x;
}
+
sub leave_node {
my $x = shift;
delete $seqn2node{$x->{id}};
$parent->{kids_size} += $self_size + $x->{kids_size};
push @{$parent->{child_id}}, $x->{id};
}
+
# output
# ...
- if ($opt_json) {
- print " " x $x->{depth};
- my $size = $self_size + $x->{kids_size};
- print qq(], "data":{ "\$area": $size } },\n);
- }
if ($opt_dot) {
- my @attr = (sprintf "label=%s", $dotnode->($x->{name}));
- push @attr, "shape=point" if $x->{type} == 2;
- printf qq{n%d [ %s ];\n}, $x->{id}, join(",", @attr);
- printf qq{n%d -> n%d;\n}, $parent->{id}, $x->{id} if $parent;
+ printf "// n%d parent=%s(type=%s)\n", $x->{id},
+ $parent ? $parent->{id} : "",
+ $parent ? $parent->{type} : ""
+ if 0;
+ if ($x->{type} != NPtype_LINK) {
+ my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
+
+ if ($x->{kids_size}) {
+ $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
+ }
+ else {
+ $name .= sprintf " +%s", fmt_size($x->{self_size});
+ }
+ $name .= " $x->{id}" if $opt_showid;
+
+ my @node_attr = (
+ sprintf("label=%s", $dotnode->($name)),
+ "id=$x->{id}",
+ );
+ my @link_attr;
+ #if ($x->{name} eq 'hek') { push @node_attr, "shape=point"; push @node_attr, "labelfontsize=6"; }
+ if ($parent) { # probably a link
+ my $parent_id = $parent->{id};
+ my @link_attr = ("id=$parent_id");
+ if ($parent->{type} == NPtype_LINK) { # link
+ (my $link_name = $parent->{name}) =~ s/->$//;
+ push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
+ $parent_id = ($stack[-2]||die "panic")->{id};
+ }
+ printf $dot_fh qq{n%d -> n%d [%s];\n},
+ $parent_id, $x->{id}, join(",", @link_attr);
+ }
+ printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
+ }
+
}
if ($dbh) {
my $attr_json = $j->encode($x->{attr});
my $leaves_json = $j->encode($x->{leaves});
$node_ins_sth->execute(
- $x->{id}, $x->{name}, $x->{title}, $x->{depth}, $x->{parent_id},
+ $x->{id}, $x->{name}, $x->{title}, $x->{type}, $x->{depth}, $x->{parent_id},
$x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
$x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
$attr_json, $leaves_json,
return;
}
+my $indent = ": ";
+my @attr_type_name = (qw(size NAME PADFAKE my PADTMP NOTE));
+my $pending_pre_attr = {};
while (<>) {
chomp;
+
my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
+
if ($type =~ s/^-//) { # Node type ($val is depth)
+ printf "%s%s%s %s [#%d @%d]\n", $indent x $val, $name,
+ ($type == NPtype_LINK) ? "->" : "",
+ $extra||'', $id, $val
+ if $opt_text;
while ($val < @stack) {
leave_node(my $x = pop @stack);
warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
if $opt_verbose;
}
- die 1 if $stack[$val];
- my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
- enter_node($node);
+ die "panic: stack already has item at depth $val"
+ if $stack[$val];
+ my $node = enter_node({
+ id => $id, type => $type, name => $name, extra => $extra,
+ attr => { %$pending_pre_attr },
+ leaves => {}, depth => $val, self_size=>0, kids_size=>0
+ });
+ %$pending_pre_attr = ();
+ $stack[$val] = $node;
$seqn2node{$id} = $node;
}
- elsif ($type eq "L") { # Leaf name and memory size
+ # --- Leaf name and memory size
+ elsif ($type eq "L") {
my $node = $seqn2node{$id} || die;
$node->{leaves}{$name} += $val;
+ printf "%s+%d %s\n", $indent x ($node->{depth}+1), $val, $name
+ if $opt_text;
}
- elsif (looks_like_number($type)) { # Attribute type, name and value
+ # --- Attribute type, name and value
+ elsif (looks_like_number($type)) {
my $node = $seqn2node{$id} || die;
my $attr = $node->{attr} || die;
- if ($type == 1) { # NPattr_NAME
+
+ # attributes to queue up and apply to the next node
+ if (NPattr_PRE_ATTR == $type) {
+ $pending_pre_attr->{$name} = $val;
+ }
+ # attributes where the string is a key (or always empty and the type is the key)
+ elsif ($type == NPattr_NAME or $type == NPattr_NOTE) {
+ printf "%s~%s(%s) %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
+ if $opt_text;
warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
if exists $attr->{$type}{$name};
$attr->{$type}{$name} = $val || $id;
- warn "A \@$id: '$name' $val\n";
$node->{title} = $name if $type == 1 and !$val;
}
- elsif (2 <= $type and $type <= 4) { # NPattr_PAD*
+ # attributes where the number is a key (or always zero)
+ elsif (NPattr_PADFAKE==$type or NPattr_PADTMP==$type or NPattr_PADNAME==$type) {
+ printf "%s~%s('%s') %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
+ if $opt_text;
warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
if defined $attr->{$type}[$val];
- $attr->{$type}[$val] = $name;
+ $attr->{+NPattr_PADNAME}[$val] = $name; # store all as NPattr_PADNAME
}
else {
+ printf "%s~%s %d [t%d]\n", $indent x ($node->{depth}+1), $name, $val, $type
+ if $opt_text;
warn "Invalid attribute type '$type' on line $. ($_)";
}
}
$dbh->commit if $dbh and $id % 10_000 == 0;
}
-my $x;
-while (@stack > 1) {
- leave_node($x = pop @stack) while @stack;
- warn "EOF ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n";
+my $top = $stack[0]; # grab top node before we pop all the nodes
+leave_node(pop @stack) while @stack;
+warn "EOF ends $top->{id} d$top->{depth}: size $top->{self_size}+$top->{kids_size}\n"
+ if $opt_verbose;
+warn Dumper($top) if $opt_verbose;
+
+if ($dot_fh) {
+ print $dot_fh "}\n";
+ close $dot_fh;
+ system("open -a Graphviz $opt_dot");
}
-print " ];\n" if $opt_json;
-print "}\n" if $opt_dot;
$dbh->commit if $dbh;
use Data::Dumper;
-warn Dumper(\$x);
-warn Dumper(\%seqn2node);
+warn Dumper(\%seqn2node) if %seqn2node; # should be empty
=for
SV(PVAV) fill=1/1 [#1 @0]
projects / p5sagit/Devel-Size.git / blobdiff