view release on metacpan or  search on metacpan

lib/Filter/Syntactic.pm  view on Meta::CPAN

        # Build handlers...
        for my $filter (@filters) {
            my $PARAMS         = join ',', map { '$'.$_ } @{$filter->{CAPTURES}};
            my $__LINE__       = _line_loc($_,$filter->{POS},$start_line);
            $filter->{HANDLER} = qq{sub ($PARAMS)}
                                  . _line_comment($_,$filter->{BLOCKPOS},$start_line)
                                  . qq{ {   # Check for nested replacements...
                                            if (\$_ ne \$_{MATCH}) {
                                                if (m{$filter->{SELFREGEX}}xms) {
                                                    ($PARAMS) = \@{$filter->{UNPACK}};
                                                }
                                                else {
                                                    warn 'filter $filter->{NAME} from ', __PACKAGE__,
                                                         ' (', __FILE__, ' $__LINE__)',
                                                         ' is not recursively self-consistent at ',
                                                         "\$_{LOC}\n";
                                                }
                                            }

                                            # Execute the transformation...
                                            $filter->{BLOCK};
                                        }
                                    }
                                  . _line_comment($_,$filter->{END},$start_line);
        }

        # Build the lookup table of transformation handlers for each filter...
        my $LUT = q{my %_HANDLER = (}
                . join(',', map { qq{ '$_->{RULENAME}' => $_->{HANDLER} } } @filters)
                . q{);};

        # Build replacement processing loops...
        my $FIRST_FILTER = 1;
        my $PROC_LOOPS = q{ my ($filename, $start_line); };
        for my $filter (@filters) {
            $PROC_LOOPS .=  q{ local @Filter::Syntactic::captures;
                                ($filename, $start_line) = (caller 1)[1,2];
                             }
                         . qq{ if (m{$filter->{FULLREGEX}}xms) }
                         . (q{ {
                                # Index captures and generate error message context info...
                                my $index = 1;
                                for my $capture (sort {$a->{POS} <=> $b->{POS}} @Filter::Syntactic::captures) {
                                    $capture->{ORD} = $index++;
                                    $capture->{LOC} = qq{$filename }
                                                    . Filter::Syntactic::_line_loc(
                                                            $_, $capture->{POS}, $start_line
                                                      );
                                }

                                # Identify and record any nested captures...
                                for my $c (reverse keys @Filter::Syntactic::captures) {
                                    my $capture = $Filter::Syntactic::captures[$c];

                                    POSSIBLE_OUTER:
                                    for my $prev (@Filter::Syntactic::captures[reverse 0..$c-1]) {
                                        last POSSIBLE_OUTER if $prev->{END} < $capture->{POS};
                                        if ($capture->{END} > $prev->{END}) {
                                            push @{$prev->{OUTERS}}, $capture;
                                            use Scalar::Util 'weaken';
                                            weaken($prev->{OUTERS}[-1]);
                                        }
                                    }
                                }

                                # Install replacement code and any adjust outer captures...
                                for my $capture
                                    (sort {$b->{POS} <=> $a->{POS}} @Filter::Syntactic::captures) {
                                        # Generate replacement code...
                                        my $replacement = do {
                                            local $_  = substr($_, $capture->{POS}, $capture->{LEN});
                                            local *_  = $capture;
                                            $_HANDLER{ $capture->{RULENAME} }(@{$capture->{CAPTURES}});
                                        };

                                        # Replace capture...
                                        substr($_, $capture->{POS}, $capture->{LEN}) = $replacement;

                                        # Adjust length of surrounding captures...
                                        my $delta = length($replacement) - $capture->{LEN};
                                        for my $outer (@{$capture->{OUTERS}}) {
                                            $outer->{LEN} += $delta;
                                        }
                                    }
                                    if ($_debugging) {
                                        Filter::Syntactic::_debug(
                                            'Before filter <FILTERNAME>' => $_prev_under,
                                            ' After filter <FILTERNAME>' => $_,
                                        );
                                        $_prev_under = $_;
                                    }
                                }
                            } =~ s{<FILTERNAME>}{$filter->{NAME}}gr
                            )
                          . ( $FIRST_FILTER
                                ? q{ else {
                                    # Failure to parse the initial source code is an external issue...
                                    my $error = $PPR::X::ERROR->origin($start_line, $filename);
                                    my $diagnostic = "syntax error at $filename line " . $error->line;
                                    $diagnostic .= qq{\nnear: }
                                                 . ($error->source =~ s{ \A (\s* \S \N* ) .* }{$1}xmsr
                                                                   =~ tr/\n/ /r)
                                        if $diagnostic !~ /, near/;
                                    die "$diagnostic\n";
                                    }
                                  }
                                : q{ else {
                                    # Report the (presumably) filter-induced syntax error...
                                    my $error = $PPR::X::ERROR->origin($start_line, $filename);
                                    my $diagnostic = "syntax error at $filename line " . $error->line;
                                    $diagnostic .= qq{\nnear: }
                                                 . ($error->source =~ s{ \A (\s* \S \N* ) .* }{$1}xmsr
                                                                   =~ tr/\n/ /r)
                                        if $diagnostic !~ /, near/;
                                    die "Possible problem with source filter at ",
                                        (caller 1)[1] . " line ", ($start_line-1) . "\n",
                                        "\n$diagnostic\n",
                                        "(possibly the result of source filtering by ",
                                        __PACKAGE__ . " at line " . ($start_line-1) . ")\n";
                                    }
                                  }