7 use DBI qw(looks_like_number);
14 # XXX import these from the XS code
15 use constant NPtype_NAME => 0x01;
16 use constant NPtype_LINK => 0x02;
17 use constant NPtype_SV => 0x03;
18 use constant NPtype_MAGIC => 0x04;
19 use constant NPtype_OP => 0x05;
21 use constant NPattr_LEAFSIZE => 0x00;
22 use constant NPattr_NAME => 0x01;
23 use constant NPattr_PADFAKE => 0x02;
24 use constant NPattr_PADNAME => 0x03;
25 use constant NPattr_PADTMP => 0x04;
26 use constant NPattr_NOTE => 0x05;
30 'text!' => \my $opt_text,
31 'dot=s' => \my $opt_dot,
32 'db=s' => \my $opt_db,
33 'verbose|v!' => \my $opt_verbose,
34 'debug|d!' => \my $opt_debug,
35 'showid!' => \my $opt_showid,
38 my $j = JSON::XS->new->ascii->pretty(0);
40 my ($dbh, $node_ins_sth);
42 $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
43 RaiseError => 1, PrintError => 0, AutoCommit => 0
45 $dbh->do("PRAGMA synchronous = OFF");
46 $dbh->do("DROP TABLE IF EXISTS node");
49 id integer primary key,
58 kids_node_count integer,
64 $node_ins_sth = $dbh->prepare(q{
65 INSERT INTO node VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
72 use HTML::Entities qw(encode_entities);;
74 my $name = encode_entities(shift);
82 open $dot_fh, ">$opt_dot";
83 print $dot_fh "digraph {\n"; # }
84 print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
89 my $kb = $size / 1024;
90 return $size if $kb < 5;
91 return sprintf "%.1fKb", $kb if $kb < 1000;
92 return sprintf "%.1fMb", $kb/1024;
99 my $parent = $stack[-1];
102 # If node is an AVelem of a CvPADLIST propagate pad name to AVelem
103 if ($parent->{name} eq 'SV(PVAV)' && @stack >= 4) {
104 if ((my $cvpl = $stack[-4])->{name} eq 'CvPADLIST') {
105 my $padnames = $cvpl->{attr}{+NPattr_PADNAME} || [];
118 delete $seqn2node{$x->{id}};
120 my $self_size = 0; $self_size += $_ for values %{$x->{leaves}};
121 $x->{self_size} = $self_size;
123 my $parent = $stack[-1];
126 $x->{parent_id} = $parent->{id};
127 # accumulate into parent
128 $parent->{kids_node_count} += 1 + ($x->{kids_node_count}||0);
129 $parent->{kids_size} += $self_size + $x->{kids_size};
130 push @{$parent->{child_id}}, $x->{id};
136 printf "// n%d parent=%s(type=%s)\n", $x->{id},
137 $parent ? $parent->{id} : "",
138 $parent ? $parent->{type} : ""
140 if ($x->{type} != NPtype_LINK) {
141 my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
143 if ($x->{kids_size}) {
144 $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
147 $name .= sprintf " +%s", fmt_size($x->{self_size});
149 $name .= " $x->{id}" if $opt_showid;
152 sprintf("label=%s", $dotnode->($name)),
156 #if ($x->{name} eq 'hek') { push @node_attr, "shape=point"; push @node_attr, "labelfontsize=6"; }
157 if ($parent) { # probably a link
158 my $parent_id = $parent->{id};
159 my @link_attr = ("id=$parent_id");
160 if ($parent->{type} == NPtype_LINK) { # link
161 (my $link_name = $parent->{name}) =~ s/->$//;
162 push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
163 $parent_id = ($stack[-2]||die "panic")->{id};
165 printf $dot_fh qq{n%d -> n%d [%s];\n},
166 $parent_id, $x->{id}, join(",", @link_attr);
168 printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
173 my $attr_json = $j->encode($x->{attr});
174 my $leaves_json = $j->encode($x->{leaves});
175 $node_ins_sth->execute(
176 $x->{id}, $x->{name}, $x->{title}, $x->{type}, $x->{depth}, $x->{parent_id},
177 $x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
178 $x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
179 $attr_json, $leaves_json,
187 my @attr_type_name = (qw(size NAME PADFAKE my PADTMP NOTE));
192 my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
194 if ($type =~ s/^-//) { # Node type ($val is depth)
195 printf "%s%s %s [#%d @%d]\n", $indent x $val, $name, $extra||'', $id, $val
197 while ($val < @stack) {
198 leave_node(my $x = pop @stack);
199 warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
202 die "panic: stack already has item at depth $val"
204 my $node = enter_node({
205 id => $id, type => $type, name => $name, extra => $extra,
206 attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0
208 $stack[$val] = $node;
209 $seqn2node{$id} = $node;
211 # --- Leaf name and memory size
212 elsif ($type eq "L") {
213 my $node = $seqn2node{$id} || die;
214 $node->{leaves}{$name} += $val;
215 printf "%s+%d %s\n", $indent x ($node->{depth}+1), $val, $name
218 # --- Attribute type, name and value
219 elsif (looks_like_number($type)) {
220 my $node = $seqn2node{$id} || die;
221 my $attr = $node->{attr} || die;
223 if ($type == NPattr_NAME or $type == NPattr_NOTE) {
224 printf "%s~%s(%s) %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
226 warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
227 if exists $attr->{$type}{$name};
228 $attr->{$type}{$name} = $val || $id;
229 $node->{title} = $name if $type == 1 and !$val;
231 elsif (NPattr_PADFAKE==$type or NPattr_PADTMP==$type or NPattr_PADNAME==$type) {
232 printf "%s~%s('%s') %d [t%d]\n", $indent x ($node->{depth}+1), $attr_type_name[$type], $name, $val, $type
234 warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
235 if defined $attr->{$type}[$val];
236 $attr->{+NPattr_PADNAME}[$val] = $name; # store all as NPattr_PADNAME
240 printf "%s~%s %d [t%d]\n", $indent x ($node->{depth}+1), $name, $val, $type
242 warn "Invalid attribute type '$type' on line $. ($_)";
246 warn "Invalid type '$type' on line $. ($_)";
249 $dbh->commit if $dbh and $id % 10_000 == 0;
252 my $top = $stack[0]; # grab top node before we pop all the nodes
253 leave_node(pop @stack) while @stack;
254 warn "EOF ends $top->{id} d$top->{depth}: size $top->{self_size}+$top->{kids_size}\n"
256 warn Dumper($top) if $opt_verbose;
261 system("open -a Graphviz $opt_dot");
264 $dbh->commit if $dbh;
267 warn Dumper(\%seqn2node) if %seqn2node; # should be empty
270 SV(PVAV) fill=1/1 [#1 @0]
277 : : : : SV(PVAV) fill=-1/-1 [#5 @4]
278 : : : : : +64 sv =168
285 N 1 0 SV(PVAV) fill=1/1
292 N 5 4 SV(PVAV) fill=-1/-1