view release on metacpan or  search on metacpan

inc/Parse/RecDescent.pm  view on Meta::CPAN

        %opt = (%opt, %{$_[0]});
        shift;
    }
    my ($grammar, $class, $sourcefile) = @_;

    $class =~ /^(\w+::)*\w+$/ or croak("Bad class name: $class");

    my $modulefile = $class;
    $modulefile =~ s/.*:://;
    $modulefile .= ".pm";

    my $runtime_package = 'Parse::RecDescent::_Runtime';
    my $code;

    local *OUT;
    open OUT, ">", $modulefile
      or croak("Can't write to new module file '$modulefile'");

    print STDERR "precompiling grammar from file '$sourcefile'\n",
      "to class $class in module file '$modulefile'\n"
      if $grammar && $sourcefile;

    # Make the resulting pre-compiled parser stand-alone by
    # including the contents of Parse::RecDescent as
    # Parse::RecDescent::Runtime in the resulting precompiled
    # parser.
    if ($opt{-standalone}) {
        local *IN;
        open IN, '<', $Parse::RecDescent::_FILENAME
          or croak("Can't open $Parse::RecDescent::_FILENAME for standalone pre-compilation: $!\n");
        my $exclude = 0;
        print OUT "{\n";
        while (<IN>) {
            if ($_ =~ /^\s*#\s*ifndef\s+RUNTIME\s*$/) {
                ++$exclude;
            }
            if ($exclude) {
                if ($_ =~ /^\s*#\s*endif\s$/) {
                    --$exclude;
                }
            } else {
                if ($_ =~ m/^__END__/) {
                    last;
                }
                s/Parse::RecDescent/$runtime_package/gs;
                print OUT $_;
            }
        }
        close IN;
        print OUT "}\n";
    }

    $self = Parse::RecDescent->new($grammar,  # $grammar
                                   1,         # $compiling
                                   $class     # $namespace
                             )
      || croak("Can't compile bad grammar")
      if $grammar;

    # Do not allow &DESTROY to remove the precompiled namespace
    delete $self->{_not_precompiled};

    foreach ( keys %{$self->{rules}} ) {
        $self->{rules}{$_}{changed} = 1;
    }


    print OUT "package $class;\n";
    if (not $opt{-standalone}) {
        print OUT "use Parse::RecDescent;\n";
    }

    print OUT "{ my \$ERRORS;\n\n";

    $code = $self->_code();
    if ($opt{-standalone}) {
        $code =~ s/Parse::RecDescent/$runtime_package/gs;
    }
    print OUT $code;

    print OUT "}\npackage $class; sub new { ";
    print OUT "my ";

    require Data::Dumper;
    $code = Data::Dumper->Dump([$self], [qw(self)]);
    if ($opt{-standalone}) {
        $code =~ s/Parse::RecDescent/$runtime_package/gs;
    }
    print OUT $code;

    print OUT "}";

    close OUT
      or croak("Can't write to new module file '$modulefile'");
}
#endif

package Parse::RecDescent::LineCounter;


sub TIESCALAR   # ($classname, \$text, $thisparser, $prevflag)
{
    bless {
        text    => $_[1],
        parser  => $_[2],
        prev    => $_[3]?1:0,
          }, $_[0];
}

sub FETCH
{
    my $parser = $_[0]->{parser};
    my $cache = $parser->{linecounter_cache};
    my $from = $parser->{fulltextlen}-length(${$_[0]->{text}})-$_[0]->{prev}
;

    unless (exists $cache->{$from})
    {
        $parser->{lastlinenum} = $parser->{offsetlinenum}
          - Parse::RecDescent::_linecount(substr($parser->{fulltext},$from))
          + 1;

inc/Parse/RecDescent.pm  view on Meta::CPAN

}

sub message ($)
{
    my ($self) = @_;
    $self->{expected} = $self->{defexpected} unless $self->{expected};
    $self->{expected} =~ s/_/ /g;
    if (!$self->{unexpected} || $self->{unexpected} =~ /\A\s*\Z/s)
    {
        return "Was expecting $self->{expected}";
    }
    else
    {
        $self->{unexpected} =~ /\s*(.*)/;
        return "Was expecting $self->{expected} but found \"$1\" instead";
    }
}

1;

package Parse::RecDescent;

use Carp;
use vars qw ( $AUTOLOAD $VERSION $_FILENAME);

my $ERRORS = 0;

our $VERSION = '1.967009';
$VERSION = eval $VERSION;
$_FILENAME=__FILE__;

# BUILDING A PARSER

my $nextnamespace = "namespace000001";

sub _nextnamespace()
{
    return "Parse::RecDescent::" . $nextnamespace++;
}

# ARGS ARE: $class, $grammar, $compiling, $namespace
sub new ($$$$)
{
    my $class = ref($_[0]) || $_[0];
    local $Parse::RecDescent::compiling = $_[2];
    my $name_space_name = defined $_[3]
        ? "Parse::RecDescent::".$_[3]
        : _nextnamespace();
    my $self =
    {
        "rules"     => {},
        "namespace" => $name_space_name,
        "startcode" => '',
        "localvars" => '',
        "_AUTOACTION" => undef,
        "_AUTOTREE"   => undef,

        # Precompiled parsers used to set _precompiled, but that
        # wasn't present in some versions of Parse::RecDescent used to
        # build precompiled parsers.  Instead, set a new
        # _not_precompiled flag, which is remove from future
        # Precompiled parsers at build time.
        "_not_precompiled" => 1,
    };


    if ($::RD_AUTOACTION) {
        my $sourcecode = $::RD_AUTOACTION;
        $sourcecode = "{ $sourcecode }"
            unless $sourcecode =~ /\A\s*\{.*\}\s*\Z/;
        $self->{_check}{itempos} =
            $sourcecode =~ /\@itempos\b|\$itempos\s*\[/;
        $self->{_AUTOACTION}
            = new Parse::RecDescent::Action($sourcecode,0,-1)
    }

    bless $self, $class;
    return $self->Replace($_[1])
}

sub Compile($$$$) {
    die "Compilation of Parse::RecDescent grammars not yet implemented\n";
}

sub DESTROY {
    my ($self) = @_;
    my $namespace = $self->{namespace};
    $namespace =~ s/Parse::RecDescent:://;
    if ($self->{_not_precompiled}) {
        # BEGIN WORKAROUND
        # Perl has a bug that creates a circular reference between
        # @ISA and that variable's stash:
        #   https://rt.perl.org/rt3/Ticket/Display.html?id=92708
        # Emptying the array before deleting the stash seems to
        # prevent the leak.  Once the ticket above has been resolved,
        # these two lines can be removed.
        no strict 'refs';
        @{$self->{namespace} . '::ISA'} = ();
        # END WORKAROUND

        # Some grammars may contain circular references between rules,
        # such as:
        #   a: 'ID' | b
        #   b: '(' a ')'
        # Unless these references are broken, the subs stay around on
        # stash deletion below.  Iterate through the stash entries and
        # for each defined code reference, set it to reference sub {}
        # instead.
        {
            local $^W; # avoid 'sub redefined' warnings.
            my $blank_sub = sub {};
            while (my ($name, $glob) = each %{"Parse::RecDescent::$namespace\::"}) {
                *$glob = $blank_sub if defined &$glob;
            }
        }

        # Delete the namespace's stash
        delete $Parse::RecDescent::{$namespace.'::'};
    }
}

# BUILDING A GRAMMAR....

# ARGS ARE: $self, $grammar, $isimplicit, $isleftop
sub Replace ($$)
{
    # set $replace = 1 for _generate
    splice(@_, 2, 0, 1);

    return _generate(@_);
}

# ARGS ARE: $self, $grammar, $isimplicit, $isleftop
sub Extend ($$)
{
    # set $replace = 0 for _generate
    splice(@_, 2, 0, 0);

    return _generate(@_);
}

sub _no_rule ($$;$)
{
    _error("Ruleless $_[0] at start of grammar.",$_[1]);
    my $desc = $_[2] ? "\"$_[2]\"" : "";
    _hint("You need to define a rule for the $_[0] $desc
           to be part of.");
}