Permalink
Browse files

fix to catch links to children of the '.' member

  • Loading branch information...
1 parent b898c64 commit 4865b4779a9ca2938b05714c485f392144ff89f8 @diakopter diakopter committed Oct 17, 2010
Showing with 29 additions and 15 deletions.
  1. +29 −15 tools/sprixel_csv.pl
View
@@ -6,23 +6,34 @@
use STD;
use Encode;
use Scalar::Util qw( blessed reftype refaddr );
+use File::Slurp;
no warnings;
my $PROG = '';
my $setting = 'CORE';
my $r;
if (@ARGV and -f $ARGV[0]) {
- $r = STD->parsefile($ARGV[0], setting => $setting);
+ $PROG = read_file($ARGV[0]);
+ $r = STD->parsefile($ARGV[0], setting => $setting);
} elsif (@ARGV) {
- $r = STD->parse($ARGV[1] || $ARGV[0], setting => $setting);
+ $PROG = $ARGV[1] || $ARGV[0];
+ $r = STD->parse($PROG, setting => $setting);
} else {
- local $/;
- $PROG = <>;
- $PROG = $PROG;
- $r = STD->parse($PROG, setting => $setting);
+ local $/;
+ $PROG = <>;
+ $PROG = $PROG;
+ $r = STD->parse($PROG, setting => $setting);
}
-#$r->{'stabs'} = $STD::ALL;
+$r->{'stabs'} = $STD::ALL;
+
+sub str_esc {
+ my $out = shift;
+ $out =~ s/([\\"])/\\$1/g;
+ $out =~ s/\n/\\n/mg;
+ return '"' . $out . '"';
+}
+
sub tps {
my $str = Encode::decode_utf8(shift);
@@ -36,21 +47,19 @@ sub tps {
}
my %idmap = ();
-my $lastid = 1;
+my $lastid = 2;
my %seen = ();
my %torun = ();
sub emit_csv {
+ say "0," . str_esc($PROG) . ",1";
emit_csv_recurse($_[0]);
}
{ package Array; }
sub get_obj_id {
- my $o = shift;
- my $a;
- my $addr = refaddr($o);
- return $idmap{$addr} //= ++$lastid;
+ return $idmap{refaddr(shift)} //= ++$lastid;
}
sub emit_csv_recurse {
@@ -61,7 +70,12 @@ sub emit_csv_recurse {
}
my $addr = get_obj_id($self);
- return if exists $seen{$addr};
+ if (exists $seen{$addr}) {
+ if (defined $parent) {
+ say "2,$addr,$parent";
+ }
+ return;
+ }
$seen{$addr} = 1;
say "$addr," . (ref $self) . ',' . ($parent // '""');
for my $prop (keys %$self) {
@@ -71,8 +85,9 @@ sub emit_csv_recurse {
if ($reftype = reftype($p)) {
my $ra = get_obj_id($p);
if ('ARRAY' eq $reftype) {
+ my $z = $p;
$p = $self->{$prop} = bless { '.' => $p }, 'Array';
- if (scalar @{$p->{'.'}}) {
+ if (scalar @$z) {
my $oid = get_obj_id($p);
say '1,' . tps($prop) . ',' . $oid;
$torun{$oid} = $p;
@@ -88,7 +103,6 @@ sub emit_csv_recurse {
}
}
if (defined $self->{'.'}) {
- my $idx = 0;
for my $kid (@{$self->{'.'}}) {
emit_csv_recurse($kid, $addr);
}

0 comments on commit 4865b47

Please sign in to comment.