view release on metacpan or  search on metacpan

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

        "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.");
}

my $NEGLOOKAHEAD    = '\G(\s*\.\.\.\!)';
my $POSLOOKAHEAD    = '\G(\s*\.\.\.)';
my $RULE        = '\G\s*(\w+)[ \t]*:';
my $PROD        = '\G\s*([|])';
my $TOKEN       = q{\G\s*/((\\\\/|\\\\\\\\|[^/])*)/([cgimsox]*)};
my $MTOKEN      = q{\G\s*(m\s*[^\w\s])};
my $LITERAL     = q{\G\s*'((\\\\['\\\\]|[^'])*)'};
my $INTERPLIT       = q{\G\s*"((\\\\["\\\\]|[^"])*)"};
my $SUBRULE     = '\G\s*(\w+)';
my $MATCHRULE       = '\G(\s*<matchrule:)';
my $SIMPLEPAT       = '((\\s+/[^/\\\\]*(?:\\\\.[^/\\\\]*)*/)?)';
my $OPTIONAL        = '\G\((\?)'.$SIMPLEPAT.'\)';
my $ANY         = '\G\((s\?)'.$SIMPLEPAT.'\)';
my $MANY        = '\G\((s|\.\.)'.$SIMPLEPAT.'\)';
my $EXACTLY     = '\G\(([1-9]\d*)'.$SIMPLEPAT.'\)';
my $BETWEEN     = '\G\((\d+)\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
my $ATLEAST     = '\G\((\d+)\.\.'.$SIMPLEPAT.'\)';
my $ATMOST      = '\G\(\.\.([1-9]\d*)'.$SIMPLEPAT.'\)';
my $BADREP      = '\G\((-?\d+)?\.\.(-?\d+)?'.$SIMPLEPAT.'\)';
my $ACTION      = '\G\s*\{';
my $IMPLICITSUBRULE = '\G\s*\(';
my $COMMENT     = '\G\s*(#.*)';
my $COMMITMK        = '\G\s*<commit>';
my $UNCOMMITMK      = '\G\s*<uncommit>';

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

                      or  _no_rule("<reject:$cond>",$line);
            }
            elsif ($grammar =~ m/(?=$SCOREMK)/gco
                and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
                      $code })
            {
                _parse("a score marker", $aftererror,$line, $code );
                $code =~ /\A\s*<score:(.*)>\Z/s;
                $prod and $prod->addscore($1, $lookahead, $line)
                      or  _no_rule($code,$line);
            }
            elsif ($grammar =~ m/(?=$AUTOSCOREMK)/gco
                and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
                     $code;
                       } )
            {
                _parse("an autoscore specifier", $aftererror,$line,$code);
                $code =~ /\A\s*<autoscore:(.*)>\Z/s;

                $rule and $rule->addautoscore($1,$self)
                      or  _no_rule($code,$line);

                $item = new Parse::RecDescent::UncondReject($lookahead,$line,$code);
                $prod and $prod->additem($item)
                      or  _no_rule($code,$line);
            }
            elsif ($grammar =~ m/$RESYNCMK/gco)
            {
                _parse("a resync to newline marker", $aftererror,$line, substr($grammar, $-[0], $+[0] - $-[0]) );
                $item = new Parse::RecDescent::Directive(
                          'if ($text =~ s/(\A[^\n]*\n)//) { $return = 0; $1; } else { undef }',
                          $lookahead,$line,"<resync>");
                $prod and $prod->additem($item)
                      or  _no_rule("<resync>",$line);
            }
            elsif ($grammar =~ m/(?=$RESYNCPATMK)/gco
                and do { ($code) = extract_bracketed($grammar,'<');
                      $code })
            {
                _parse("a resync with pattern marker", $aftererror,$line, $code );
                $code =~ /\A\s*<resync:(.*)>\Z/s;
                $item = new Parse::RecDescent::Directive(
                          'if ($text =~ s/(\A'.$1.')//) { $return = 0; $1; } else { undef }',
                          $lookahead,$line,$code);
                $prod and $prod->additem($item)
                      or  _no_rule($code,$line);
            }
            elsif ($grammar =~ m/(?=$SKIPMK)/gco
                and do { ($code) = extract_codeblock($grammar,'<');
                      $code })
            {
                _parse("a skip marker", $aftererror,$line, $code );
                $code =~ /\A\s*<skip:(.*)>\Z/s;
                if ($rule) {
                    $item = new Parse::RecDescent::Directive(
                        'my $oldskip = $skip; $skip='.$1.'; $oldskip',
                        $lookahead,$line,$code);
                    $prod and $prod->additem($item)
                      or  _no_rule($code,$line);
                } else {
                    #global <skip> directive
                    $self->{skip} = $1;
                }
            }
            elsif ($grammar =~ m/(?=$RULEVARPATMK)/gco
                and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
                     $code;
                       } )
            {
                _parse("a rule variable specifier", $aftererror,$line,$code);
                $code =~ /\A\s*<rulevar:(.*)>\Z/s;

                $rule and $rule->addvar($1,$self)
                      or  _no_rule($code,$line);

                $item = new Parse::RecDescent::UncondReject($lookahead,$line,$code);
                $prod and $prod->additem($item)
                      or  _no_rule($code,$line);
            }
            elsif ($grammar =~ m/(?=$AUTOACTIONPATMK)/gco
                and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
                     $code;
                       } )
            {
                _parse("an autoaction specifier", $aftererror,$line,$code);
                $code =~ s/\A\s*<autoaction:(.*)>\Z/$1/s;
                if ($code =~ /\A\s*[^{]|[^}]\s*\Z/) {
                    $code = "{ $code }"
                }
        $self->{_check}{itempos} =
            $code =~ /\@itempos\b|\$itempos\s*\[/;
        $self->{_AUTOACTION}
            = new Parse::RecDescent::Action($code,0,-$line)
            }
            elsif ($grammar =~ m/(?=$DEFERPATMK)/gco
                and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
                     $code;
                       } )
            {
                _parse("a deferred action specifier", $aftererror,$line,$code);
                $code =~ s/\A\s*<defer:(.*)>\Z/$1/s;
                if ($code =~ /\A\s*[^{]|[^}]\s*\Z/)
                {
                    $code = "{ $code }"
                }

                $item = new Parse::RecDescent::Directive(
                          "push \@{\$thisparser->{deferred}}, sub $code;",
                          $lookahead,$line,"<defer:$code>");
                $prod and $prod->additem($item)
                      or  _no_rule("<defer:$code>",$line);

                $self->{deferrable} = 1;
            }
            elsif ($grammar =~ m/(?=$TOKENPATMK)/gco
                and do { ($code) = extract_codeblock($grammar,'{',undef,'<');
                     $code;
                       } )
            {
                _parse("a token constructor", $aftererror,$line,$code);
                $code =~ s/\A\s*<token:(.*)>\Z/$1/s;