#!/usr/bin/perl -w use strict; $|++; # $::RD_TRACE = 80; $::RD_HINT = 1; use Parse::RecDescent; use Data::Dumper; ## define grammar my $parser = Parse::RecDescent->new(q{ { my %TABLE; } file: { %TABLE = (); } assignment(s?) /\z/ { \%TABLE } assignment: scalar_assignment | scalar_assignment: scalar_lvalue '=' scalar_rvalue ';' { ${$item{scalar_lvalue}} = ${$item{scalar_rvalue}}; 1; } ## lvalues, indicated as reference to value, so we can assign to them scalar_lvalue: deref_head deref_chain(?) { my $return = $item{deref_head}; if ($item{deref_chain}) { for (@{$item{deref_chain}[0]}) { if ($_->[0] eq "hash") { $return = \$$return->{${$_->[1]}}; } elsif ($_->[0] eq "array") { $return = \$$return->[${$_->[1]}]; } else { die "what is $_->[0]?" } } } $return; } deref_head: simple_scalar_lvalue | simple_scalar_rvalue deref_chain: "->" hash_or_array_subscript deref_chain_more(s?) { [$item[2], @{$item[3]}] } deref_chain_more: "->" hash_or_array_subscript | hash_or_array_subscript hash_or_array_subscript: hash_subscript | array_subscript hash_subscript: "{" scalar_constant "}" { ["hash", $item{scalar_constant}] } array_subscript: "[" scalar_constant "]" { ["array", $item{scalar_constant}] } simple_scalar_lvalue: '$' ident { \ $TABLE{'$' . $item{ident}} } ident: /[^\W\d]\w*/ simple_scalar_lvalue: '$' '{' scalar_rvalue '}' { \ ${${$item{scalar_rvalue}}} } ## rvalues, indicated as reference to value, because "undef" is legal scalar_rvalue: simple_scalar_rvalue | scalar_lvalue simple_scalar_rvalue: scalar_constant scalar_constant: 'undef' { \ undef } scalar_constant: /-?[1-9]\d*|0/ { \ $item[1] } scalar_constant: { \ $item[1][2] } simple_scalar_rvalue: "\x5C" scalar_rvalue { \ $item{scalar_rvalue} } simple_scalar_rvalue: '[' scalar_rvalue(s? /,/) ']' { \ [map $$_, @{$item[2]}] } simple_scalar_rvalue: '{' hashpair(s? /,/) '}' { \ {map @$_, @{$item[2]}} } hashpair: scalar_constant '=>' scalar_rvalue { [${$item{scalar_constant}}, ${$item{scalar_rvalue}}] } simple_scalar_rvalue: 'bless' '(' scalar_rvalue ',' scalar_constant ')' { \ bless( ${$item{scalar_rvalue}}, ${$item{scalar_constant}} ) } simple_scalar_rvalue: 'do' '{' "\x5C" '(' 'my' '$o' '=' scalar_rvalue ')' '}' { \ do { \ (my $o = ${$item{scalar_rvalue}})} } }) or die "compile"; ## following tests from t/dumper.t in 5.6.1 distribution if (0) { my @c = ('c'); my $c = \@c; my $b = {}; my $a = [1, $b, $c]; $b->{a} = $a; $b->{b} = $a->[1]; $b->{c} = $a->[2]; test([$a, $b, $c], [qw(a b c)]); } if (0) { my $foo = { "abc\000\'\efg" => "mno\000", "reftest" => \\1, }; test([$foo], [qw($foo)]); } if (0) { my $foo = 5; my @foo = (-10,\$foo); my %foo = (a=>1,b=>\$foo,c=>\@foo); $foo{d} = \%foo; $foo[2] = \%foo; test([\%foo],[qw($foo)]); } if (0) { my @dogs = ( 'Fido', 'Wags' ); my %kennel = ( First => \$dogs[0], Second => \$dogs[1], ); $dogs[2] = \%kennel; my $mutts = \%kennel; test([\@dogs, \%kennel, $mutts], [qw($dogs $kennel $mutts)]); } if (0) { my $a = []; $a->[1] = \$a->[0]; test([$a], [qw($a)]); } if (0) { my $a = \\\\\'foo'; my $b = $$$a; test([$a, $b], [qw($a $b)]); } if (1) { my $b; my $a = [{ a => \$b }, { b => undef }]; $b = [{ c => \$b }, { d => \$a }]; timetest([$a, $b], [qw($a $b)]); } if (0) { my $a = [[[[\\\\\'foo']]]]; my $b = $a->[0][0]; my $c = $${$b->[0][0]}; test([$a, $b, $c], [qw($a $b $c)]); } if (0) { my $f = "pearl"; my $e = [ $f ]; my $d = { 'e' => $e }; my $c = [ $d ]; my $b = { 'c' => $c }; my $a = { 'b' => $b }; test([$a, $b, $c, $d, $e, $f], [qw($a $b $c $d $e $f)]); } if (0) { my $a; $a = \$a; my $b = [$a]; test([$b], [qw($b)]); } ## end of tests from t/dumper.t, now some of my own if (0) { my $x = bless {fred => 'flintstone'}, 'x'; my $y = bless \$x, 'y'; timetest([$x, $y], [qw($x $y)]); } sub test { my $input = Data::Dumper->new(@_)->Purity(1)->Dumpxs; print "=" x 60, "\ninput:\n$input\n==>\noutput:\n"; my $symbol = $parser->file($input) or die "execute"; print Data::Dumper->new([values %$symbol], [keys %$symbol])->Purity(1)->Dumpxs; } sub timetest { require Benchmark; my $input = Data::Dumper->new(@_)->Purity(1)->Dumpxs; print "=" x 60, "\ninput:\n$input\n==>\noutput:\n"; Benchmark::timethese(0, { PRD => sub { package Dummy; no strict; my $symbol = $parser->file($input) or die "execute"; }, EVAL => sub { package Dummy; no strict; eval $input; }, }); }