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