7 use DBI qw(looks_like_number);
14 'text!' => \my $opt_text,
15 'dot=s' => \my $opt_dot,
16 'db=s' => \my $opt_db,
17 'verbose|v!' => \my $opt_verbose,
18 'debug|d!' => \my $opt_debug,
19 'showid!' => \my $opt_showid,
22 my $j = JSON::XS->new->ascii->pretty(0);
24 my ($dbh, $node_ins_sth);
26 $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
27 RaiseError => 1, PrintError => 0, AutoCommit => 0
29 $dbh->do("PRAGMA synchronous = OFF");
30 $dbh->do("DROP TABLE IF EXISTS node");
33 id integer primary key,
42 kids_node_count integer,
48 $node_ins_sth = $dbh->prepare(q{
49 INSERT INTO node VALUES (?,?,?,?,?,?, ?,?,?,?,?,?)
56 use HTML::Entities qw(encode_entities);;
58 my $name = encode_entities(shift);
66 open $dot_fh, ">$opt_dot";
67 print $dot_fh "digraph {\n"; # }
68 print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
73 my $kb = $size / 1024;
74 return $size if $kb < 5;
75 return sprintf "%.1fKb", $kb if $kb < 1000;
76 return sprintf "%.1fMb", $kb/1024;
83 #printf $fh qq{\tn%d [ %s ]\n}, $x->{id}, $dotnode->($x->{name});
84 #print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
91 delete $seqn2node{$x->{id}};
93 my $self_size = 0; $self_size += $_ for values %{$x->{leaves}};
94 $x->{self_size} = $self_size;
96 my $parent = $stack[-1];
99 $x->{parent_id} = $parent->{id};
100 # accumulate into parent
101 $parent->{kids_node_count} += 1 + ($x->{kids_node_count}||0);
102 $parent->{kids_size} += $self_size + $x->{kids_size};
103 push @{$parent->{child_id}}, $x->{id};
108 printf "// n%d parent=%s(type=%s)\n", $x->{id},
109 $parent ? $parent->{id} : "",
110 $parent ? $parent->{type} : ""
112 if ($x->{type} != 2) {
113 my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
115 if ($x->{kids_size}) {
116 $name .= sprintf " %s+%s=%s", fmt_size($x->{self_size}), fmt_size($x->{kids_size}), fmt_size($x->{self_size}+$x->{kids_size});
119 $name .= sprintf " +%s", fmt_size($x->{self_size});
121 $name .= " $x->{id}" if $opt_showid;
124 sprintf("label=%s", $dotnode->($name)),
128 #if ($x->{name} eq 'hek') { push @node_attr, "shape=point"; push @node_attr, "labelfontsize=6"; }
129 if ($parent) { # probably a link
130 my $parent_id = $parent->{id};
131 my @link_attr = ("id=$parent_id");
132 if ($parent->{type} == 2) { # link
133 (my $link_name = $parent->{name}) =~ s/->$//;
134 push @link_attr, (sprintf "label=%s", $dotnode->($link_name));
135 $parent_id = ($stack[-2]||die "panic")->{id};
137 printf $dot_fh qq{n%d -> n%d [%s];\n},
138 $parent_id, $x->{id}, join(",", @link_attr);
140 printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
145 my $attr_json = $j->encode($x->{attr});
146 my $leaves_json = $j->encode($x->{leaves});
147 $node_ins_sth->execute(
148 $x->{id}, $x->{name}, $x->{title}, $x->{type}, $x->{depth}, $x->{parent_id},
149 $x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
150 $x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
151 $attr_json, $leaves_json,
162 my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
163 if ($type =~ s/^-//) { # Node type ($val is depth)
164 printf "%s%s %s [#%d @%d]\n", $indent x $val, $name, $extra||'', $id, $val
166 while ($val < @stack) {
167 leave_node(my $x = pop @stack);
168 warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
171 die "panic: stack already has item at depth $val"
173 my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
175 $seqn2node{$id} = $node;
177 elsif ($type eq "L") { # Leaf name and memory size
178 my $node = $seqn2node{$id} || die;
179 $node->{leaves}{$name} += $val;
180 printf "%s+%d %s\n", $indent x ($node->{depth}+1), $val, $name
183 elsif (looks_like_number($type)) { # Attribute type, name and value
184 my $node = $seqn2node{$id} || die;
185 my $attr = $node->{attr} || die;
186 printf "%s~%s %d [t%d]\n", $indent x ($node->{depth}+1), $name, $val, $type
188 if ($type == 1 or $type == 5) { # NPattr_NAME
189 warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
190 if exists $attr->{$type}{$name};
191 $attr->{$type}{$name} = $val || $id;
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;
210 my $top = $stack[0]; # grab top node before we pop all the nodes
211 leave_node(pop @stack) while @stack;
212 warn "EOF ends $top->{id} d$top->{depth}: size $top->{self_size}+$top->{kids_size}\n"
214 warn Dumper($top) if $opt_verbose;
219 system("open -a Graphviz $opt_dot");
222 $dbh->commit if $dbh;
225 warn Dumper(\%seqn2node) if %seqn2node; # should be empty
228 SV(PVAV) fill=1/1 [#1 @0]
235 : : : : SV(PVAV) fill=-1/-1 [#5 @4]
236 : : : : : +64 sv =168
243 N 1 0 SV(PVAV) fill=1/1
250 N 5 4 SV(PVAV) fill=-1/-1