view release on metacpan or  search on metacpan

lib/Regexp/Grammars.pm  view on Meta::CPAN

    my $logfile = q{-};

    my $log_where = "for regex grammar defined at $source_file line $source_line";
    $grammar_spec =~ s{ ^ [^#]* < logfile: \s* ([^>]+?) \s* > }{
        $logfile = _timestamp($1);

        # Presence of <logfile:...> implies compile-time logging...
        $compiletime_debugging_requested = 1;
        *Regexp::Grammars::LOGFILE = _open_log('>',$logfile, $log_where );

        # Delete <logfile:...> directive...
        q{};
    }gexms;

    # Look ahead for any run-time debugging or timeout requests...
    my $runtime_debugging_requested
        = $grammar_spec =~ m{
              ^ [^#]*
              < debug: \s* (run | match | step | try | on | same ) \s* >
            | \$DEBUG (?! \s* (?: \[ | \{) )
        }xms;

    my $timeout_requested
        = $grammar_spec =~ m{
              ^ [^#]*
              < timeout: \s* \d+ \s* >
        }xms;


    # Standard actions set up and clean up any regex debugging...
    # Before entire match, set up a stack of attempt records and report...
    my $pre_match_debug
        = $runtime_debugging_requested
            ? qq{(?{; *Regexp::Grammars::LOGFILE
                        = Regexp::Grammars::_open_log('>>','$logfile', '$log_where');
                      Regexp::Grammars::_init_try_stack(); })}
            : qq{(?{; *Regexp::Grammars::LOGFILE
                        = Regexp::Grammars::_open_log('>>','$logfile', '$log_where'); })}
            ;

    # After entire match, report whether successful or not...
    my $post_match_debug
        = $runtime_debugging_requested
            ? qq{(?{;Regexp::Grammars::_debug_matched(0,\\%/,'<grammar>',\$^N)})
                |(?>(?{;Regexp::Grammars::_debug_handle_failures(0,'<grammar>'); }) (?!))
                }
            : q{}
            ;

    # Remove comment lines...
    $grammar_spec =~ s{^ ([^#\n]*) \s \# [^\n]* }{$1}gxms;

    # Subdivide into rule and token definitions, preparing to process each...
    # REWRITE THIS, USING (PROBABLY NEED TO REFACTOR ALL GRAMMARS TO REUSe
    # THESE COMPONENTS:
    #   (?<PARAMLIST> \( \s* (?&PARAMS)? \s* \) | (?# NOTHING )                                          )
    #   (?<PARAMS>    (?&PARAM) \s* (?: , \s* (?&PARAM) \s* )*  ,?                                       )
    #   (?<PARAM>     (?&VAR) (?: \s* = \s* (?: (?&LITERAL) | (?&PARENCODE) ) )?                         )
    #   (?<LITERAL>   (?&NUMBER) | (?&STRING) | (?&VAR)                                                  )
    #   (?<VAR>       : (?&IDENT)                                                                        )
    my @defns = split m{
            (< (obj|)(rule|token) \s*+ :
              \s*+ ((?:${IDENT}::)*+) (?: ($IDENT) \s*+ = \s*+ )?+
              ($IDENT)
            \s* >)
        }xms, $grammar_spec;

    # Extract up list of names of defined rules/tokens...
    # (Name is every 6th item out of every seven, skipping the first item)
    my @subrule_names = @defns[ map { $_ * 7 + 6 } 0 .. ((@defns-1)/7-1) ];
    my @defns_copy = @defns[1..$#defns];
    my %subrule_names;

    # Build a look-up table of subrule names, checking for duplicates...
    my $defn_line = $source_line + $defns[0] =~ tr/\n//;
    my %first_decl_explanation;
    for my $subrule_name (@subrule_names) {
        my ($full_decl, $objectify, $type, $qualifier, $name, $callname, $body) = splice(@defns_copy, 0, 7);
        if (++$subrule_names{$subrule_name} > 1) {
            _debug_notify( warn =>
                "Redeclaration of <$objectify$type: $subrule_name>",
                "at $source_file line $defn_line",
                "will be ignored.",
                @{ $first_decl_explanation{$subrule_name} },
                q{},
            );
        }
        else {
            $first_decl_explanation{$subrule_name} = [
                "(Hidden by the earlier declaration of <$objectify$type: $subrule_name>",
                " at $source_file line $defn_line)"
            ];
        }
        $defn_line += ($full_decl.$body) =~ tr/\n//;
    }

    # Add the built-ins...
    @subrule_names{'ws', 'hk', 'matchpos', 'matchline'} = (1) x 4;

    # An empty main rule will never match anything...
    my $main_regex = shift @defns;
    if ($main_regex =~ m{\A (?: \s++ | \(\?\# [^)]* \) | \# [^\n]++ )* \z}xms) {
        _debug_notify( error =>
            "No main regex specified before rule definitions",
            "in regex grammar declared at $source_file line $source_line",
            "Grammar will never match anything.",
            "(Or did you forget a <grammar:...> specification?)",
            q{},
        );
    }

    # Compile the regex or grammar...
    my $regex = q{};
    my $grammar_name;
    my $is_grammar;

    # Is this a grammar specification?
    if ($main_regex =~ $GRAMMAR_DIRECTIVE) {
        # Normalize grammar name and report...
        $grammar_name = $+{grammar_name};
        if ($grammar_name !~ /::/) {