File Coverage

blib/lib/Parse/RecDescent/Deparse.pm

Criterion	Covered	Total	%
statement	44	99	44.4
branch	2	26	7.6
condition	0	21	0.0
subroutine	15	17	88.2
pod	0	3	0.0
total	61	166	36.7

package Parse::RecDescent::Deparse;
use Parse::RecDescent;

use 5.006;
use strict;
use warnings;

$Parse::RecDescent::Deparse::VERSION = '1.00';

# This is not a Parse::RecDescent optimizer.

# Given a grammar
#
#       a : b
#       b : 'foo' c 'baz'
#       c : 'bar'
#
# repeated calls to ->hoist will produce
#
#       a : 'foo' c 'baz'
#       b : 'foo' 'bar' 'baz'
#       c : 'bar'
#
# and
#
#       a : 'foo' 'bar' 'baz'
#       b : 'foo' 'bar' 'baz'
#       c : 'bar'

sub Parse::RecDescent::hoist {
    my $self = shift;
    RULE: for (values %{$self->{rules}}) {
        my @directly_calls =
            map { $_->{subrule} }
            grep { ref $_ eq "Parse::RecDescent::Subrule" }
            map { @{$_->{items}} }
            @{$_->{prods}};
        for my $subrule (@directly_calls) {
            $subrule = $self->{rules}->{$subrule};
            next if @{$subrule->{prods}} > 1 or !@{$subrule->{prods}};
            #print "Hoisting $subrule->{name} into $_->{name}\n";
            for my $prod (@{$_->{prods}}) {
                for my $i (0..$#{$prod->{items}}) {
                    if (ref $prod->{items}[$i] eq
                        "Parse::RecDescent::Subrule" and
                        $prod->{items}[$i]{subrule} eq $subrule->{name}) {
                    splice (@{$prod->{items}}, $i, 1, map {bless{ %$_ }, ref$_} @{$subrule->{prods}[0]->{items}}); # Ugly hack
                    return;
                    }
                }
            }
        }
    }
}

# Given a grammar
#
# a : 'b' /c/ "d"
#
# ->merge_literals will produce
#
# a : 'bcd'

sub Parse::RecDescent::merge_literals {
    my $self = shift;
    for (values %{$self->{rules}}) {
        for (@{$_->{prods}}) {
            for (@{$_->{items}}) {
                if (ref $_ eq "Parse::RecDescent::Token" and
                    $_->{pattern} !~ /[\(\[\]\)\+\*\?\\\^]/ and
                    $_->{pattern} !~ /\$$/) {
                    bless $_, "Parse::RecDescent::InterpLit";
                }
                if (ref $_ eq "Parse::RecDescent::InterpLit" and
                    $_->{pattern} !~ /(^|[^\\])[\$\@]/) {
                    bless $_, "Parse::RecDescent::Literal";
                }
            }
            next unless @{$_->{items}} > 1;
            RETRY: for my $i (1..$#{$_->{items}}) {
                if (ref $_->{items}[$i] eq "Parse::RecDescent::Literal"
                    and (ref $_->{items}[$i-1] eq "Parse::RecDescent::Literal"
                    or ref $_->{items}[$i-1] eq "Parse::RecDescent::InterpLit")
                   ) {
                   if (ref $_->{items}[$i-1] eq "Parse::RecDescent::InterpLit") {
                       $_->{items}[$i-1]{pattern} =~ s/([\@\$])::(\w+)$/$1::{$2}/;
                   }
                   $_->{items}[$i-1]->{pattern} .= (splice @{$_->{items}}, $i, 1)->{pattern};
                   # XXX Swizzle item numbers here.
                   goto RETRY;
                }
            }
        }
    }
}

sub Parse::RecDescent::deparse {
    my $self = shift;
    return join "", map {" $_ : ".$self->{rules}->{$_}->deparse."\n"}
           sort {
                $self->{rules}->{$a}->{line}
                    <=>
                $self->{rules}->{$b}->{line}
              }
           keys %{$self->{rules}};
}

sub Parse::RecDescent::Rule::deparse {
    my $self = shift;
    return join " | ", map { $_->deparse } @{$self->{prods}};
}

sub Parse::RecDescent::Production::deparse {
    my $self = shift;
    return join " ", map {$_->deparse} @{$self->{items}};
}

sub Parse::RecDescent::InterpLit::deparse {
    my $dq = (shift)->{pattern};
    return qq{"$dq"} if $dq !~ /"/;
    return "qq{$dq}" if $dq !~ /[\{\}]/;
    no warnings; # Sheesh
    for (qw(/ # !)) { return "qq$_$dq$_" if $dq !~ /$_/; }
    # Sodding hell.
    $dq =~ s/"/\\"/g;
    return qq{"$dq"};
}

sub Parse::RecDescent::Subrule::deparse {
    my $self = shift;
    return $self->{subrule};
}

sub Parse::RecDescent::Literal::deparse {
    my $self = shift;
    my $q = $self->{pattern};
    return qq{'$q'} if $q !~ /'/;
    return "q{$q}" if $q !~ /[\{\}]/;
    no warnings;
    for (qw(/ # !)) { return "q$_$q$_" if $q !~ /$_/; }
    # Sodding hell.
    $q =~ s/'/\\'/g;
    return qq{'$q'};
}

sub Parse::RecDescent::Token::deparse {
    my $self = shift;
    return "m".$self->{ldelim}.$self->{pattern}.$self->{rdelim};
}

sub Parse::RecDescent::Action::deparse {
    my $self = shift;
    return $self->{code};
}

sub Parse::RecDescent::Repetition::deparse {
    my $self = shift;
    return $self->{subrule}."($self->{repspec})";
}

=head1 NAME

Parse::RecDescent::Deparse - Turn a Parse::RecDescent object back into its grammar

=head1 SYNOPSIS

  use Parse::RecDescent::Deparse;

  my $foo = new Parse::RecDescent($grammar);
  print $foo->deparse;

=head1 DESCRIPTION

This module adds the C method to the C
class, which returns a textual description of the grammar.

Why? There are at least two equally unlikely reasons why this could be
useful:

=over 3

=item *

You're working on something which grovels around in the
C object data structure and want to view the effects
of your changes. For instance, a C optimizer. (This
 package does not contain a functional C optimizer.)

=item *

You want to understand how C does what it does, and
fancy the source of this package is a bit more of a gentle introduction
than the source of C itself.

=back

=head2 BUGS

C can correctly deparse the metagrammar for
C input, so that's a good thing. There are no bugs in
the C optimizer as it clearly does not exist.


=head1 AUTHOR

Simon Cozens, C

=head1 SEE ALSO

L.

=cut