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