memnodes.pl

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5 use autodie;
   6
   7 use DBI qw(looks_like_number);
   8 use DBD::SQLite;
   9 use JSON::XS;
  10
  11 use Getopt::Long;
  12
  13 GetOptions(
  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,
  20 ) or exit 1;
  21
  22 my $j = JSON::XS->new->ascii->pretty(0);
  23
  24 my ($dbh, $node_ins_sth);
  25 if ($opt_db) {
  26     $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
  27         RaiseError => 1, PrintError => 0, AutoCommit => 0
  28     });
  29     $dbh->do("PRAGMA synchronous = OFF");
  30     $dbh->do("DROP TABLE IF EXISTS node");
  31     $dbh->do(q{
  32         CREATE TABLE node (
  33             id integer primary key,
  34             name text,
  35             title text,
  36             type integer,
  37             depth integer,
  38             parent_id integer,
  39
  40             self_size integer,
  41             kids_size integer,
  42             kids_node_count integer,
  43             child_ids text,
  44             attr_json text,
  45             leaves_json text
  46         )
  47     });
  48     $node_ins_sth = $dbh->prepare(q{
  49         INSERT INTO node VALUES (?,?,?,?,?,?,  ?,?,?,?,?,?)
  50     });
  51 }
  52
  53 my @stack;
  54 my %seqn2node;
  55
  56 use HTML::Entities qw(encode_entities);;
  57 my $dotnode = sub {
  58     my $name = encode_entities(shift);
  59     $name =~ s/"/\\"/g;
  60     return '"'.$name.'"';
  61 };
  62
  63
  64 my $dot_fh;
  65 if ($opt_dot) {
  66     open $dot_fh, ">$opt_dot";
  67     print $dot_fh "digraph {\n"; # }
  68     print $dot_fh "graph [overlap=false]\n"; # target="???", URL="???"
  69 }
  70
  71 sub fmt_size {
  72     my $size = shift;
  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;
  77 }
  78
  79
  80 sub enter_node {
  81     my $x = shift;
  82     if ($opt_dot) {
  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);
  85     }
  86     return;
  87 }
  88
  89 sub leave_node {
  90     my $x = shift;
  91     delete $seqn2node{$x->{id}};
  92
  93     my $self_size = 0; $self_size += $_  for values %{$x->{leaves}};
  94     $x->{self_size} = $self_size;
  95
  96     my $parent = $stack[-1];
  97     if ($parent) {
  98         # link to parent
  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};
 104     }
 105     # output
 106     # ...
 107     if ($opt_dot) {
 108         printf "// n%d parent=%s(type=%s)\n", $x->{id},
 109                 $parent ? $parent->{id} : "",
 110                 $parent ? $parent->{type} : ""
 111             if 0;
 112         if ($x->{type} != 2) {
 113             my $name = $x->{title} ? "\"$x->{title}\" $x->{name}" : $x->{name};
 114
 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});
 117             }
 118             else {
 119                 $name .= sprintf " +%s", fmt_size($x->{self_size});
 120             }
 121             $name .= " $x->{id}" if $opt_showid;
 122
 123             my @node_attr = (
 124                 sprintf("label=%s", $dotnode->($name)),
 125                 "id=$x->{id}",
 126             );
 127             my @link_attr;
 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};
 136                 }
 137                 printf $dot_fh qq{n%d -> n%d [%s];\n},
 138                     $parent_id, $x->{id}, join(",", @link_attr);
 139             }
 140             printf $dot_fh qq{n%d [ %s ];\n}, $x->{id}, join(",", @node_attr);
 141         }
 142
 143     }
 144     if ($dbh) {
 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,
 152         );
 153         # XXX attribs
 154     }
 155     return;
 156 }
 157
 158 my $indent = ":   ";
 159
 160 while (<>) {
 161     chomp;
 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
 165             if $opt_text;
 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"
 169                 if $opt_verbose;
 170         }
 171         die 1 if $stack[$val];
 172         my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
 173         enter_node($node);
 174         $seqn2node{$id} = $node;
 175     }
 176     elsif ($type eq "L") {  # Leaf name and memory size
 177         my $node = $seqn2node{$id} || die;
 178         $node->{leaves}{$name} += $val;
 179         printf "%s+%d %s\n", $indent x ($node->{depth}+1), $val, $name
 180             if $opt_text;
 181     }
 182     elsif (looks_like_number($type)) {  # Attribute type, name and value
 183         my $node = $seqn2node{$id} || die;
 184         my $attr = $node->{attr} || die;
 185         printf "%s~%s %d [t%d]\n", $indent x ($node->{depth}+1), $name, $val, $type
 186             if $opt_text;
 187         if ($type == 1 or $type == 5) { # 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             $node->{title} = $name if $type == 1 and !$val;
 192         }
 193         elsif (2 <= $type and $type <= 4) { # NPattr_PAD*
 194             warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
 195                 if defined $attr->{$type}[$val];
 196             $attr->{$type}[$val] = $name;
 197         }
 198         else {
 199             warn "Invalid attribute type '$type' on line $. ($_)";
 200         }
 201     }
 202     else {
 203         warn "Invalid type '$type' on line $. ($_)";
 204         next;
 205     }
 206     $dbh->commit if $dbh and $id % 10_000 == 0;
 207 }
 208
 209 my $x;
 210 while (@stack > 1) {
 211     leave_node($x = pop @stack) while @stack;
 212     warn "EOF ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
 213         if $opt_verbose;
 214 }
 215
 216 if ($dot_fh) {
 217     print $dot_fh "}\n";
 218     close $dot_fh;
 219     system("open -a Graphviz $opt_dot");
 220 }
 221
 222 $dbh->commit if $dbh;
 223
 224 use Data::Dumper;
 225 warn Dumper(\$x) if $opt_verbose;
 226 warn Dumper(\%seqn2node) if %seqn2node; # should be empty
 227
 228 =for
 229 SV(PVAV) fill=1/1       [#1 @0]
 230 :   +64 sv =64
 231 :   +16 av_max =80
 232 :   AVelem->        [#2 @1]
 233 :   :   SV(RV)      [#3 @2]
 234 :   :   :   +24 sv =104
 235 :   :   :   RV->        [#4 @3]
 236 :   :   :   :   SV(PVAV) fill=-1/-1     [#5 @4]
 237 :   :   :   :   :   +64 sv =168
 238 :   AVelem->        [#6 @1]
 239 :   :   SV(IV)      [#7 @2]
 240 :   :   :   +24 sv =192
 241 192 at -e line 1.
 242 =cut
 243 __DATA__
 244 N 1 0 SV(PVAV) fill=1/1
 245 L 1 64 sv
 246 L 1 16 av_max
 247 N 2 1 AVelem->
 248 N 3 2 SV(RV)
 249 L 3 24 sv
 250 N 4 3 RV->
 251 N 5 4 SV(PVAV) fill=-1/-1
 252 L 5 64 sv
 253 N 6 1 AVelem->
 254 N 7 2 SV(IV)
 255 L 7 24 sv