memnodes.pl

   1 #!/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use DBI qw(looks_like_number);
   7 use DBD::SQLite;
   8 use JSON::XS;
   9
  10 use Getopt::Long;
  11
  12 GetOptions(
  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 ) or exit 1;
  19
  20 my $j = JSON::XS->new->ascii->pretty(0);
  21
  22 my $dbh = DBI->connect("dbi:SQLite:dbname=$opt_db","","", {
  23     RaiseError => 1, PrintError => 0, AutoCommit => 0
  24 });
  25 $dbh->do("PRAGMA synchronous = OFF");
  26 $dbh->do("DROP TABLE IF EXISTS node");
  27 $dbh->do(q{
  28     CREATE TABLE node (
  29         id integer primary key,
  30         name text,
  31         title text,
  32         depth integer,
  33         parent_id integer,
  34
  35         self_size integer,
  36         kids_size integer,
  37         kids_node_count integer,
  38         child_ids text,
  39         attr_json text,
  40         leaves_json text
  41     )
  42 });
  43 my $node_ins_sth = $dbh->prepare(q{
  44     INSERT INTO node VALUES (?,?,?,?,?,  ?,?,?,?,?,?)
  45 });
  46
  47 my @stack;
  48 my %seqn2node;
  49
  50     my $dotnode = sub {
  51         my $name = shift;
  52         $name =~ s/"/\\"/g;
  53         return '"'.$name.'"';
  54     };
  55
  56 print "memnodes = [" if $opt_json;
  57
  58 if ($opt_dot) {
  59     print "digraph {\n"; # }
  60     print "graph [overlap=false]\n"; # target="???", URL="???"
  61 }
  62
  63
  64 sub enter_node {
  65     my $x = shift;
  66     if ($opt_json) {
  67         print "    " x $x->{depth};
  68         print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
  69     }
  70     if ($opt_dot) {
  71         #printf $fh qq{\tn%d [ %s ]\n}, $x->{id}, $dotnode->($x->{name});
  72         #print qq({ "id": "$x->{id}", "name": "$x->{name}", "depth":$x->{depth}, "children":[ \n);
  73     }
  74     return;
  75 }
  76
  77 sub leave_node {
  78     my $x = shift;
  79     delete $seqn2node{$x->{id}};
  80
  81     my $self_size = 0; $self_size += $_  for values %{$x->{leaves}};
  82     $x->{self_size} = $self_size;
  83
  84     my $parent = $stack[-1];
  85     if ($parent) {
  86         # link to parent
  87         $x->{parent_id} = $parent->{id};
  88         # accumulate into parent
  89         $parent->{kids_node_count} += 1 + ($x->{kids_node_count}||0);
  90         $parent->{kids_size} += $self_size + $x->{kids_size};
  91         push @{$parent->{child_id}}, $x->{id};
  92     }
  93     # output
  94     # ...
  95     if ($opt_json) {
  96         print "    " x $x->{depth};
  97         my $size = $self_size + $x->{kids_size};
  98         print qq(], "data":{ "\$area": $size } },\n);
  99     }
 100     if ($opt_dot) {
 101         my @attr = (sprintf "label=%s", $dotnode->($x->{name}));
 102         push @attr, "shape=point" if $x->{type} == 2;
 103         printf qq{n%d [ %s ];\n}, $x->{id}, join(",", @attr);
 104         printf qq{n%d -> n%d;\n}, $parent->{id}, $x->{id} if $parent;
 105     }
 106     if ($dbh) {
 107         my $attr_json = $j->encode($x->{attr});
 108         my $leaves_json = $j->encode($x->{leaves});
 109         $node_ins_sth->execute(
 110             $x->{id}, $x->{name}, $x->{title}, $x->{depth}, $x->{parent_id},
 111             $x->{self_size}, $x->{kids_size}, $x->{kids_node_count},
 112             $x->{child_id} ? join(",", @{$x->{child_id}}) : undef,
 113             $attr_json, $leaves_json,
 114         );
 115         # XXX attribs
 116     }
 117     return;
 118 }
 119
 120
 121 while (<>) {
 122     chomp;
 123     my ($type, $id, $val, $name, $extra) = split / /, $_, 5;
 124     if ($type =~ s/^-//) {     # Node type ($val is depth)
 125         while ($val < @stack) {
 126             leave_node(my $x = pop @stack);
 127             warn "N $id d$val ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n"
 128                 if $opt_verbose;
 129         }
 130         die 1 if $stack[$val];
 131         my $node = $stack[$val] = { id => $id, type => $type, name => $name, extra => $extra, attr => {}, leaves => {}, depth => $val, self_size=>0, kids_size=>0 };
 132         enter_node($node);
 133         $seqn2node{$id} = $node;
 134     }
 135     elsif ($type eq "L") {  # Leaf name and memory size
 136         my $node = $seqn2node{$id} || die;
 137         $node->{leaves}{$name} += $val;
 138     }
 139     elsif (looks_like_number($type)) {  # Attribute type, name and value
 140         my $node = $seqn2node{$id} || die;
 141         my $attr = $node->{attr} || die;
 142         if ($type == 1) { # NPattr_NAME
 143             warn "Node $id already has attribute $type:$name (value $attr->{$type}{$name})\n"
 144                 if exists $attr->{$type}{$name};
 145             $attr->{$type}{$name} = $val || $id;
 146             warn "A \@$id: '$name' $val\n";
 147             $node->{title} = $name if $type == 1 and !$val;
 148         }
 149         elsif (2 <= $type and $type <= 4) { # NPattr_PAD*
 150             warn "Node $id already has attribute $type:$name (value $attr->{$type}[$val])\n"
 151                 if defined $attr->{$type}[$val];
 152             $attr->{$type}[$val] = $name;
 153         }
 154         else {
 155             warn "Invalid attribute type '$type' on line $. ($_)";
 156         }
 157     }
 158     else {
 159         warn "Invalid type '$type' on line $. ($_)";
 160         next;
 161     }
 162     $dbh->commit if $dbh and $id % 10_000 == 0;
 163 }
 164
 165 my $x;
 166 while (@stack > 1) {
 167     leave_node($x = pop @stack) while @stack;
 168     warn "EOF ends $x->{id} d$x->{depth}: size $x->{self_size}+$x->{kids_size}\n";
 169 }
 170 print " ];\n" if $opt_json;
 171 print "}\n" if $opt_dot;
 172
 173 $dbh->commit if $dbh;
 174
 175 use Data::Dumper;
 176 warn Dumper(\$x);
 177 warn Dumper(\%seqn2node);
 178
 179 =for
 180 SV(PVAV) fill=1/1       [#1 @0]
 181 :   +64 sv =64
 182 :   +16 av_max =80
 183 :   AVelem->        [#2 @1]
 184 :   :   SV(RV)      [#3 @2]
 185 :   :   :   +24 sv =104
 186 :   :   :   RV->        [#4 @3]
 187 :   :   :   :   SV(PVAV) fill=-1/-1     [#5 @4]
 188 :   :   :   :   :   +64 sv =168
 189 :   AVelem->        [#6 @1]
 190 :   :   SV(IV)      [#7 @2]
 191 :   :   :   +24 sv =192
 192 192 at -e line 1.
 193 =cut
 194 __DATA__
 195 N 1 0 SV(PVAV) fill=1/1
 196 L 1 64 sv
 197 L 1 16 av_max
 198 N 2 1 AVelem->
 199 N 3 2 SV(RV)
 200 L 3 24 sv
 201 N 4 3 RV->
 202 N 5 4 SV(PVAV) fill=-1/-1
 203 L 5 64 sv
 204 N 6 1 AVelem->
 205 N 7 2 SV(IV)
 206 L 7 24 sv