6 use DBI qw(looks_like_number);
13 'json!' => \my $opt_json,
14 'dot!' => \my $opt_dot,
15 'db=s' => \my $opt_db,
16 'verbose|v!' => \my $opt_verbose,
17 'debug|d!' => \my $opt_debug,
18 'showid!' => \my $opt_showid,
21 my $j = JSON::XS->new->ascii->pretty(0);
23 my ($dbh, $node_ins_sth);
25 $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
26 RaiseError => 1, PrintError => 0, AutoCommit => 0
28 $dbh->do("PRAGMA synchronous = OFF");
29 $dbh->do("DROP TABLE IF EXISTS node");
32 id integer primary key,
41 kids_node_count integer,
47 $node_ins_sth = $dbh->prepare(q{
48 INSERT INTO node VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
55 use HTML::Entities qw(encode_entities);;
57 my $name = encode_entities(shift);
62 print "memnodes = [" if $opt_json;
65 print "digraph {\n"; # }
66 print "graph [overlap=false]\n"; # target="???", URL="???"
71 my $kb = $size / 1024;
72 return $size if $kb < 5;
73 return sprintf "%.1fKb", $kb if $kb < 1000;
74 return sprintf "%.1fMb", $kb/1024;
81 print " " x $x->{depth};
82 print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
85 #printf $fh qq{\tn%d [ %s ]\n}, $x->{id}, $dotnode->($x->{name});
86 #print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
93 delete $seqn2node{$x->{id}};
95 my $self_size = 0; $self_size += $_ for values %{$x->{leaves}};
96 $x->{self_size} = $self_size;
98 my $parent = $stack[-1];
101 $x->{parent_id} = $parent->{id};
102 # accumulate into parent
103 $parent->{kids_node_count} += 1 + ($x->{kids_node_count}||0);
104 $parent->{kids_size} += $self_size + $x->{kids_size};
105 push @{$parent->{child_id}}, $x->{id};
110 print "\t" x $x->{depth};
111 my $size = $self_size + $x->{kids_size};
112 print qq(], "data":{ "\$area": $size } },\n);
115 printf "// n%d parent=%s(type=%s)\n", $x->{id},
116 $parent ? $parent->{id} : "",
117 $parent ? $parent->{type} : ""
119 if ($x->{type} != 2) {
120 my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
122 if ($x->{kids_size}) {
123 $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
126 $name .= sprintf " +%s", fmt_size($x->{self_size});
128 $name .= " $x->{id}" if $opt_showid;
131 sprintf("label=%s", $dotnode->($name)),
135 #if ($x->{name} eq 'hek') { push @node_attr, "shape=point"; push @node_attr, "labelfontsize=6"; }
136 if ($parent) { # probably a link
137 my $parent_id = $parent->{id};
138 my @link_attr = ("id=$parent_id");
139 if ($parent->{type} == 2) { # link
140 (my $link_name = $parent->{name}) =~ s/->$//;
141 push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
142 $parent_id = ($stack[-2]||die "panic")->{id};
144 printf qq{n%d -> n%d [%s];\n},
145 $parent_id, $x->{id}, join(",", @link_attr);
147 printf qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
152 my $attr_json = $j->encode($x->{attr});
153 my $leaves_json = $j->encode($x->{leaves});
154 $node_ins_sth->execute(
155 $x->{id}, $x->{name}, $x->{title}, $x->{type}, $x->{depth}, $x->{parent_id},
156 $x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
157 $x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
158 $attr_json, $leaves_json,
168 my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
169 if ($type =~ s/^-//) { # Node type ($val is depth)
170 while ($val < @stack) {
171 leave_node(my $x = pop @stack);
172 warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
175 die 1 if $stack[$val];
176 my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
178 $seqn2node{$id} = $node;
180 elsif ($type eq "L") { # Leaf name and memory size
181 my $node = $seqn2node{$id} || die;
182 $node->{leaves}{$name} += $val;
184 elsif (looks_like_number($type)) { # Attribute type, name and value
185 my $node = $seqn2node{$id} || die;
186 my $attr = $node->{attr} || die;
187 if ($type == 1) { # NPattr_NAME
188 warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
189 if exists $attr->{$type}{$name};
190 $attr->{$type}{$name} = $val || $id;
191 warn "A \@$id: '$name' $val\n";
192 $node->{title} = $name if $type == 1 and !$val;
194 elsif (2 <= $type and $type <= 4) { # NPattr_PAD*
195 warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
196 if defined $attr->{$type}[$val];
197 $attr->{$type}[$val] = $name;
200 warn "Invalid attribute type '$type' on line $. ($_)";
204 warn "Invalid type '$type' on line $. ($_)";
207 $dbh->commit if $dbh and $id % 10_000 == 0;
212 leave_node($x = pop @stack) while @stack;
213 warn "EOF ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n";
215 print " ];\n" if $opt_json;
216 print "}\n" if $opt_dot;
218 $dbh->commit if $dbh;
222 warn Dumper(\%seqn2node);
225 SV(PVAV) fill=1/1 [#1 @0]
232 : : : : SV(PVAV) fill=-1/-1 [#5 @4]
233 : : : : : +64 sv =168
240 N 1 0 SV(PVAV) fill=1/1
247 N 5 4 SV(PVAV) fill=-1/-1