22

✏️ Editing: demo_undumper.pl

From merlyn@stonehenge.com  Fri Jul 13 09:47:35 2001
Received: from nexus.csse.monash.edu.au (nexus.csse.monash.edu.au [130.194.226.4])
	by indy05.csse.monash.edu.au (SGI-8.9.3/8.9.3) with ESMTP id JAA19597
	for <damian@indy05.csse.monash.edu.au>; Fri, 13 Jul 2001 09:47:35 +1000 (EST)
Received: from ALPHA9.CC.MONASH.EDU.AU (alpha9.cc.monash.edu.au [130.194.1.9])
	by nexus.csse.monash.edu.au (8.9.3+Sun/8.9.3) with ESMTP id JAA28599
	for <damian.conway@mail.csse.monash.edu.au>; Fri, 13 Jul 2001 09:47:32 +1000 (EST)
Received: from c000.snv.cp.net ([209.228.32.59])
 by vaxh.cc.monash.edu.au (PMDF V5.2-31 #29714)
 with SMTP id <01K5VMB591048YCMRT@vaxh.cc.monash.edu.au> for
 damian.conway@mail.csse.monash.edu.au; Fri, 13 Jul 2001 09:47:15 +1000
Received: (cpmta 24211 invoked from network); Thu, 12 Jul 2001 16:46:12 -0700
Received: (cpmta 24197 invoked from network); Thu, 12 Jul 2001 16:46:10 -0700
Received: from halfdome.holdit.com (209.102.105.64)
 by smtp.c000.snv.cp.net (209.228.32.59) with SMTP; Thu,
 12 Jul 2001 16:46:10 -0700
Received: (from merlyn@localhost)	by halfdome.holdit.com (8.9.1/8.9.1)
 id QAA21492; Thu, 12 Jul 2001 16:46:09 -0700
X-Received: 12 Jul 2001 23:46:10 GMT
Date: Thu, 12 Jul 2001 16:46:09 -0700
From: merlyn@stonehenge.com (Randal L. Schwartz)
Subject: new potential example for P::RD's eg directory?
To: damian@conway.org
Message-id: <m1n16990e6.fsf@halfdome.holdit.com>
MIME-version: 1.0
Content-type: MULTIPART/MIXED; BOUNDARY="Boundary_(ID_V8Qg38zNd7FfillEy8fgog)"
Delivered-to: conway.org%damian@conway.org
User-Agent: Gnus/5.0808 (Gnus v5.8.8) Emacs/20.3
X-UID: Inbox;992469057;10334
Lines: 15
Status: RO

--Boundary_(ID_V8Qg38zNd7FfillEy8fgog)
Content-type: TEXT/PLAIN
Content-transfer-encoding: 7BIT

I just wrote a "Data::Dumper" undumper using P::RD.  I'm attaching the
magazine column (which you can't re-use, unfortunately) but perhaps
the code itself can be put in P::RD's distro (with a small README) as
an example of an interesting grammar and usage.

Or perhaps you can develop it into a full reference/dereference parser?

--
Randal L. Schwartz - Stonehenge Consulting Services, Inc. - +1 503 777 0095
<merlyn@stonehenge.com> <URL:http://www.stonehenge.com/merlyn/>
Perl/Unix/security consulting, Technical writing, Comedy, etc. etc.
See PerlTraining.Stonehenge.com for onsite and open-enrollment Perl training!

--Boundary_(ID_V8Qg38zNd7FfillEy8fgog)
Content-type: TEXT/PLAIN; NAME=col29.pod
Content-description: col 29 linux magazine
Content-disposition: attachment; filename=col29.pod
Content-transfer-encoding: 7BIT

=head1 Linux Magazine Column 29 (Oct 2001)

[suggested title: Safe Undumping]

Recently on the Perl Monestary at C<http://www.perlmonks.org/>, the
user known as C<ton> asked about parsing a Perl-style double-quoted
string, as part of a project to construct a safe C<Data::Dumper>
parser that would take the output and interpret it rather than handing
the result directly to C<eval> as is typically done.  A few postings
later, the work in progress for their C<Undumper> was posted, and I commented
that there was probably a simpler way to do some of the things,
and that it didn't handle blessed references.

Well, me and my big mouth.  Or was it my continuing curiousity to
tinker with Damian Conway's excellent C<Parse::RecDescent> module? I'm
not sure, but I found myself over the next dozen hours or so staring
at C<Data::Dumper> source code, output, test cases, and
C<Parse::RecDescent> traces and documentation.  I also pounded my head
on the desk for better than a day trying to figure out how to break a
left-recursion loop, and came up with a nice obvious (now!) solution.

The point of this is to be able to take the output of C<Data::Dumper>
and reconstruct the original data, but not open ourselves to the
possibility of being fed dangerous constructs, like backticks or
symbol-table-manipulating code.  Sure, you could also do this with the
right use of the C<Safe> module, but I was already committed to
finishing this version before I thought of that.  Maybe another column
someday.

But anyway, that brings us to the program in [listing one, below].
Most of this program is input to C<Parse::RecDescent>, so I'll start
by setting that aside and describing the Perl support structure first.

Lines 1 through 3 start nearly every program I write, turning on
warnings, compiler restrictions, and disabling the buffering on
C<STDOUT>.

Lines 5 and 6 control the behaviour of C<Parse::RecDescent>. When
tracing is enabled (although commented out here), I can see how the
parse is progressing. The number 80 trims the "to-be-parsed" string
dumping to its first 80 characters, which is usually plenty for me to
see what's going on. I left hints enabled, because the error messages
that result from a hint were often helpful in debugging the grammar.

Lines 8 and 9 pull in the C<Parse::RecDescent> (found in the CPAN) and
C<Data::Dumper> (part of the core Perl distribution) modules.

Lines 13 to 81 form the input grammar for C<Parse::RecDescent>,
included as a single-quoted string using C<q{}> for delimiters. Damian
Conway seems to prefer this quoting style for sending stuff to
C<Parse::RecDescent>, so I've copied it at least here. In other
places, I might have used a "here-document" instead. The result of
feeding this grammar to C<Parse::RecDescent> is a parser object that
we can then call on to parse the output of C<Data::Dumper> to "undump"
it. If the grammar is bad, we die in line 81. At that point
C<Parse::RecDescent> has already printed its own diagnostics, expanded
by the enabled "hint" flag earlier.

During development, I probably changed this grammar over 50 times,
constantly tweaking it to recognize each new thing that I encountered
in the input source. The hints were often useful, although the "left
recursion" problem (that I'll describe later) had me stumped for the
better part of two days.

Once we have a parser object (in $parser), the action to "undump" a
string containing Perl code is simple.  Skipping down quickly to the
C<test> subroutine starting at line 177, we can see the use of this
C<$parser> to take a given C<$input> and transform it to a hashref
response (saved as C<$symbol> here). The keys of the hashref contain
the top-level scalar variable names, which default to C<$VAR1>,
C<$VAR2> and so on, unless overridden during the dumping. The values
of this hashref are then the corresponding values of those variables
from the original dump, as best can be reconstructed.

The C<test> subroutine here uses C<Data::Dumper> to convert an
existing collection of values (passed in as arguments) into a string,
shows the string as the input to the undumper, then parses the string
with the constructed parser object. The output of this undumping
process is then dumped once again and shown. The comparison process
has to be a manual one, because it is sensitive to the order in which
the items are presented to C<Data::Dumper>.

Above the definition of this testing routine is a series of tests that
I used to develop and verify the undumper.  I started with the
included tests found in the Perl 5.6.1 distribution to verify Perl on
initial installation.  I actually didn't include the entire test, but
took the data structure for each applicable test and copied that into
this program.  I skipped over the tests that included symbol-table
references (using globs) or coderefs, because I chose to ignore that
for this program.  Each test provides an arrayref containing the
references to be dumped, and most tests also provide a label list to
keep the variables from simply being named C<$VAR1>, C<$VAR2> and so
on.

I enclosed each test in a conditional that I could switch between "if
(0)" and "if (1)" to either run the test or skip it.  When I was
focussing on a new feature, I enabled only one test until it worked,
but once I got a good run, I reenabled all previous tests to ensure
that I didn't break something else in the process.

The "Extreme Programming" technique relies on this strategy of
creating tests first and driving the development from those tests, and
it worked nicely for the development of this program.  Other than a
few snippets of code that I used for scaffolding to test some initial
grammar ideas, all of the code that I used to develop and test this
code is thereby archived along with the routines, for later
maintenance to take place easily.

Any one of the tests can be switched to invoke C<timetest> rather than
C<test>, as I've done on the final test (starting in line 171).  This
final test, by the way, exercises blessed references (objects), which
none of the distribution tests even approach.  (Maybe a patch to the
distribution's C<t/dumper.t> is in order?)  Using C<timetest>, we pop
down to the routine beginning in line 184, which runs a quick
benchmark comparing a straight C<eval> with our safe undumping parser.
I'm using the C<timethese> routine from C<Benchmark> (a standard Perl
module), giving it the default "0 times", which attempts to run each
routine for slighly over 3 CPU seconds to compute an interations per
second for each type.

The bad news is that my code clocks in at 1/100th of the speed of
C<eval>.  Ahh, the price to pay for safety.  The good news is that the
speed difference is probably negligible for typical applications, and
pennies to pay for the dollars saved in having a safe evaluation of
what should be good C<Data::Dumper> output.

Well, what little Perl code there is (outside of the grammar), that's
it.  So let's pick apart the grammar now, starting back up at line 13.

Line 15 declares a variable local to the parser for the "symbol table"
we'll be creating.  The keys will be the full variable names as given
in the dump. The values will be the constructed value for that
key. Yes, this is the hash that is returned upon a successful parse.

Line 17 defines the top-level rule for the parse.  A "file" is zero or
more "assignments".  Howver, we also have to clear out the possibly
leftover values from the previous run, and this is handled by the
action block immediately preceding the assignment. We also have to
verify that we've parsed the entire input string, which I'll do by
matching C</\z/>, which matches only at the end of the string. If all
went well, we'll return the hashref.

Line 19 defines an assignment.  Currently, I'm handling only a scalar
assignment, although C<Data::Dumper> can also generate array and hash
assignments under some circumstances.  Gotta leave something for
"release 2.0".

Lines 21 and 22 define a scalar assignment, and the action to take for
that.  A scalar assignment consists of an "lvalue" (like a variable)
and an "rvalue" (like an expression).  Both lvalues and rvalues are
references, so we dereference each of them in the action, and perform
the requested assignment to keep our "virtual Perl symbol table" up to
date.  The action returns a constant 1 to let the parent rule know
that this rule succeeded.  Without that, an C<undef> value being
assigned would have caused that rule to fail (one of my debugging
attempts revealed such, with much head-banging-on-desk until I
realized what I was doing).

Lvalues are defined starting in line 24.  The most complex lvalue is a
dereferenced scalar reference, handled in lines 26 to 47.  This is
because C<Data::Dumper> can generate a reference path to a specific
entry in the data structure to patch it up so that it points to a
proper place for complex data interelationships.  For example, if an
element of C<@a> points to C<@b>, but an element of C<@b> points to
C<@a>, the "chicken-and-egg" tie is broken by first generating C<@a>
without the C<@b> reference, then C<@b> with the C<@a> reference, then
patching up C<@a> finally to point to C<@b>.

The definition starting in line 26 uses a C<deref_head> to be a simple
scalar, followed by an optional C<deref_chain> which is one or more
array-element or hash element dereferences.  Let's look at the syntax
before we study the actions taken.  Line 39 shows us that
C<deref_head> is either a C<simple_scalar_lvalue> or
C<simple_scalar_rvalue>.

Further down in lines 49 and 53, we see that a C<simple_scalar_lvalue>
can be either a scalar variable or a scalar reference dereference.
And that would form the head of the chain.  If it's a scalar variable,
we take a reference to a hash element in our "symbol table", and
return that.  The key is the name of the variable, including the
dollar sign.  This permits eventual expansion to include arrays and
hashes in our "symbol table", again for version 2.0.  For the
dereference of the scalar reference, we emulate the same steps in our
virtual world, again returning a reference for all lvalues.

Once we have the chain head, we then look for a dereference chain
(line 40), starting with the mandatory arrow then a hash or array
subscript expression.  This may be followed with additional
arrow-optional hash or array subscript expressions (line 42).  Each
subscript is returned as a two-element arrayref, with either the
keyword "hash" or "array" followed by the scalar constant selecting
the particular element (lines 45 and 47).  The action in line 41 rolls
up the deref chain as a reference to an array of those two-element
arrayrefs.

Back in line 26, we thus have a reference to a starting point for the
C<deref_head>, and possible one or more dereferences to apply to it.
The action in lines 27 to 37 walk the dereference chain to get to the
final target lvalue, and return it (as a reference to a scalar
somewhere in our virtual Perl symbol space).

On the other side of the equation, we've got rvalues of various
shapes, defined in line 58 to be either a C<simple_scalar_rvalue> or a
C<scalar_lvalue>.  The loop back to C<scalar_value> is necessary
because any variable reference is also itself a source of values.

Lines 60 to 66 define the only scalar constants that C<Data::Dumper>
seems to emit: C<undef>, simple signed integers, and quoted strings.
These values are returned as references to those values so that
C<undef> can be a valid return value: again, something I figured out
the hard way after my rule for C<undef> kept breaking.

Lines 68 to 75 handle the reference values: scalar references, array
references, and hash references.  Again, the syntax is very narrow:
just the types of things I was able to see C<Data::Dumper> generate,
both by trying some sample data, and by lightly examining the source
code to C<Data::Dumper>.  I may have missed a form or two, in which
case this grammar will make it easy to add additional forms.

The grammar is nicely recursive: an array reference in turn contains
one or more C<scalar_rvalue> items, which brings us right back to the
same place in the hierarchy, but at a nested level.

Lines 76 to 79 handle blessed references. Again, the syntax is very
specific to what I was able to determine about C<Data::Dumper>'s
behavior.

And that's pretty much it.  The grammar looks for a series of
assignments, each of which is an lvalue being given an rvalue.  Some
of the lvalues ultimately lead to symbol table entries, which then
populate our symbol table hash with keys and values when assigned.
Rvalues can be constants, or pointers into existing data in the symbol
table.  OK, it I<is> somewhat full of smoke and mirrors, and I was
rather pleased when the whole thing worked.  And on some rainy Oregon
afternoon, I hope to extend it to handle arrays and hashes as well, just
to make it extremely flexible and universal. I even have some ideas
about how to get it to handle globs. But that's for another day: until
next time, enjoy!

=head2 Listing

=1=     #!/usr/bin/perl -w
        =2=     use strict;
        =3=     $|++;
        =4=
        =5=     # $::RD_TRACE = 80;
        =6=     $::RD_HINT = 1;
        =7=
        =8=     use Parse::RecDescent;
        =9=     use Data::Dumper;
        =10=
        =11=    ## define grammar
        =12=
        =13=    my $parser = Parse::RecDescent->new(q{
        =14=
        =15=    { my %TABLE; }
        =16=
        =17=    file: { %TABLE = (); } assignment(s?) /\z/ { \%TABLE }
        =18=
        =19=    assignment: scalar_assignment | <error>
        =20=
        =21=    scalar_assignment: scalar_lvalue '=' scalar_rvalue ';'
        =22=      { ${$item{scalar_lvalue}} = ${$item{scalar_rvalue}}; 1; }
        =23=
        =24=    ## lvalues, indicated as reference to value, so we can assign to them
        =25=
        =26=    scalar_lvalue: deref_head deref_chain(?) {
        =27=      my $return = $item{deref_head};
        =28=      if ($item{deref_chain}) {
        =29=        for (@{$item{deref_chain}[0]}) {
        =30=          if ($_->[0] eq "hash") {
        =31=            $return = \$$return->{${$_->[1]}};
        =32=          } elsif ($_->[0] eq "array") {
        =33=            $return = \$$return->[${$_->[1]}];
        =34=          } else { die "what is $_->[0]?" }
        =35=        }
        =36=      }
        =37=      $return;
        =38=    }
        =39=    deref_head: simple_scalar_lvalue | simple_scalar_rvalue
        =40=    deref_chain: "->" hash_or_array_subscript deref_chain_more(s?)
        =41=      { [$item[2], @{$item[3]}] }
        =42=    deref_chain_more: "->" hash_or_array_subscript | hash_or_array_subscript
        =43=    hash_or_array_subscript: hash_subscript | array_subscript
        =44=    hash_subscript: "{" scalar_constant "}"
        =45=      { ["hash", $item{scalar_constant}] }
        =46=    array_subscript: "[" scalar_constant "]"
        =47=      { ["array", $item{scalar_constant}] }
        =48=
        =49=    simple_scalar_lvalue: '$' ident
        =50=      { \ $TABLE{'$' . $item{ident}} }
        =51=    ident: /[^\W\d]\w*/
        =52=
        =53=    simple_scalar_lvalue: '$' '{' scalar_rvalue '}'
        =54=      { \ ${${$item{scalar_rvalue}}} }
        =55=
        =56=    ## rvalues, indicated as reference to value, because "undef" is legal
        =57=
        =58=    scalar_rvalue: simple_scalar_rvalue | scalar_lvalue
        =59=
        =60=    simple_scalar_rvalue: scalar_constant
        =61=    scalar_constant: 'undef'
        =62=      { \ undef }
        =63=    scalar_constant: /-?[1-9]\d*|0/
        =64=      { \ $item[1] }
        =65=    scalar_constant: <perl_quotelike>
        =66=      { \ $item[1][2] }
        =67=
        =68=    simple_scalar_rvalue: "\x5C" scalar_rvalue
        =69=      { \ $item{scalar_rvalue} }
        =70=    simple_scalar_rvalue: '[' scalar_rvalue(s? /,/) ']'
        =71=      { \ [map $$_, @{$item[2]}] }
        =72=    simple_scalar_rvalue: '{' hashpair(s? /,/) '}'
        =73=      { \ {map @$_, @{$item[2]}} }
        =74=    hashpair: scalar_constant '=>' scalar_rvalue
        =75=      { [${$item{scalar_constant}}, ${$item{scalar_rvalue}}] }
        =76=    simple_scalar_rvalue: 'bless' '(' scalar_rvalue ',' scalar_constant ')'
        =77=      { \ bless( ${$item{scalar_rvalue}}, ${$item{scalar_constant}} ) }
        =78=    simple_scalar_rvalue: 'do' '{' "\x5C" '(' 'my' '$o' '=' scalar_rvalue ')' '}'
        =79=      { \ do { \ (my $o = ${$item{scalar_rvalue}})} }
        =80=
        =81=    }) or die "compile";
        =82=
        =83=    ## following tests from t/dumper.t in 5.6.1 distribution
        =84=
        =85=    if (0) {
        =86=      my @c = ('c');
        =87=      my $c = \@c;
        =88=      my $b = {};
        =89=      my $a = [1, $b, $c];
        =90=      $b->{a} = $a;
        =91=      $b->{b} = $a->[1];
        =92=      $b->{c} = $a->[2];
        =93=
        =94=      test([$a, $b, $c], [qw(a b c)]);
        =95=    }
        =96=
        =97=    if (0) {
        =98=      my $foo = { "abc\000\'\efg" => "mno\000",
        =99=                  "reftest" => \\1,
        =100=               };
        =101=
        =102=     test([$foo], [qw($foo)]);
        =103=   }
        =104=
        =105=   if (0) {
        =106=     my $foo = 5;
        =107=     my @foo = (-10,\$foo);
        =108=     my %foo = (a=>1,b=>\$foo,c=>\@foo);
        =109=     $foo{d} = \%foo;
        =110=     $foo[2] = \%foo;
        =111=
        =112=     test([\%foo],[qw($foo)]);
        =113=   }
        =114=
        =115=   if (0) {
        =116=     my @dogs = ( 'Fido', 'Wags' );
        =117=     my %kennel = (
        =118=               First => \$dogs[0],
        =119=               Second =>  \$dogs[1],
        =120=              );
        =121=     $dogs[2] = \%kennel;
        =122=     my $mutts = \%kennel;
        =123=     test([\@dogs, \%kennel, $mutts], [qw($dogs $kennel $mutts)]);
        =124=   }
        =125=
        =126=   if (0) {
        =127=     my $a = [];
        =128=     $a->[1] = \$a->[0];
        =129=     test([$a], [qw($a)]);
        =130=   }
        =131=
        =132=   if (0) {
        =133=     my $a = \\\\\'foo';
        =134=     my $b = $$$a;
        =135=     test([$a, $b], [qw($a $b)]);
        =136=   }
        =137=
        =138=   if (1) {
        =139=     my $b;
        =140=     my $a = [{ a => \$b }, { b => undef }];
        =141=     $b = [{ c => \$b }, { d => \$a }];
        =142=     timetest([$a, $b], [qw($a $b)]);
        =143=   }
        =144=
        =145=   if (0) {
        =146=     my $a = [[[[\\\\\'foo']]]];
        =147=     my $b = $a->[0][0];
        =148=     my $c = $${$b->[0][0]};
        =149=     test([$a, $b, $c], [qw($a $b $c)]);
        =150=   }
        =151=
        =152=   if (0) {
        =153=     my $f = "pearl";
        =154=     my $e = [        $f ];
        =155=     my $d = { 'e' => $e };
        =156=     my $c = [        $d ];
        =157=     my $b = { 'c' => $c };
        =158=     my $a = { 'b' => $b };
        =159=     test([$a, $b, $c, $d, $e, $f], [qw($a $b $c $d $e $f)]);
        =160=   }
        =161=
        =162=   if (0) {
        =163=     my $a;
        =164=     $a = \$a;
        =165=     my $b = [$a];
        =166=     test([$b], [qw($b)]);
        =167=   }
        =168=
        =169=   ## end of tests from t/dumper.t, now some of my own
        =170=
        =171=   if (0) {
        =172=     my $x = bless {fred => 'flintstone'}, 'x';
        =173=     my $y = bless \$x, 'y';
        =174=     timetest([$x, $y], [qw($x $y)]);
        =175=   }
        =176=
        =177=   sub test {
        =178=     my $input = Data::Dumper->new(@_)->Purity(1)->Dumpxs;
        =179=     print "=" x 60, "\ninput:\n$input\n==>\noutput:\n";
        =180=     my $symbol = $parser->file($input) or die "execute";
        =181=     print Data::Dumper->new([values %$symbol], [keys %$symbol])->Purity(1)->Dumpxs;
        =182=   }
        =183=
        =184=   sub timetest {
        =185=     require Benchmark;
        =186=
        =187=     my $input = Data::Dumper->new(@_)->Purity(1)->Dumpxs;
        =188=     print "=" x 60, "\ninput:\n$input\n==>\noutput:\n";
        =189=     Benchmark::timethese(0, {
        =190=                              PRD => sub {
        =191=                                package Dummy;
        =192=                                no strict;
        =193=                                my $symbol = $parser->file($input)
        =194=                                  or die "execute";
        =195=                              },
        =196=                              EVAL => sub {
        =197=                                package Dummy;
        =198=                                no strict;
        =199=                                eval $input;
        =200=                              },
        =201=                             });
        =202=   }

--Boundary_(ID_V8Qg38zNd7FfillEy8fgog)--

MR SKB