File Coverage

blib/lib/Filter/Syntactic.pm

Criterion	Covered	Total	%
statement	61	71	85.9
branch	6	12	50.0
condition	5	10	50.0
subroutine	10	11	90.9
pod			n/a
total	82	104	78.8

package Filter::Syntactic;

use 5.022;
use warnings;

our $VERSION = '0.000002';

use Filter::Simple;
use PPR::X;
use experimental 'signatures';

sub _expected ($what = q{}) {
    state ($expected, $unexpected);
    if ($what) {
        $expected   = $what;
        $unexpected = do { substr($_,pos()) =~ m{ \A \s* (\S \N*) } ? $1 : substr($_,pos(),20) };
    }
    else {
        my $expectation = qq{Expected $expected but found "$unexpected"};
        $expected = $unexpected = q{};
        return $expectation;
    }
}

# Extract context information...
sub _line_comment ($str, $pos, $line_offset) {
    $pos //= 0;
    return "\n#" . _line_loc($str, $pos, $line_offset) . "\n";
}

sub _line_loc ($str, $pos, $line_offset) {
    $pos //= 0;
    my $line_num = $line_offset + (substr($str,0,$pos) =~ tr/\n//);
    return "line $line_num";
}

sub import {
    # Generated filters use subroutine signatures (which were experimental until 5.36)...
    if ($] < 5.36) {
        experimental->import('signatures');
    }
}

FILTER {
    return if m{ \A __(DATA|END)__ \n }xms;

    # Remember where we parked...
    my ($filename, $start_line) = (caller 1)[1,2];

    # What filter blocks look like...
    my @filters;
    my $PERL_WITH_FILTER_BLOCKS = qr{
        \A (?&PerlEntireDocument) \z

        (?(DEFINE)
            (? (?>
                filter \b
                (?>
                    (?<_>                                                              (?>(?&PerlNWS))
                        (?{ _expected('PPR rule name') })
                        (?(? [A-Za-z_]++                          ))   (?>(?&PerlOWS))
                        (?{ _expected('mode, rule, or code block') })
                        (?             :extend |                            )    (?>(?&PerlOWS))
                        (?{ _expected('rule or code block') })
                        (?            \( (?>(?&PPR_X_balanced_parens)) \)  )?+  (?>(?&PerlOWS))
                        (?{ _expected('code block') })
                        (?            (?>(?&PerlBlock))                    )
                    )
                    (?{ _expected();
                        my $len = length($+{_}) + 6;
                        push @filters, { POS => pos() - $len, LEN => $len, END => pos(),
                                         BLOCKPOS => pos() - length($+{BLOCK}), %+ };
                    })
                |
                    (?{ push @filters, { POS => pos() - 6, EXPECTED => _expected(), INVALID => 1 } })
                )
            |
                (?>(?&PerlStdControlBlock))
            ))
        )

        $PPR::X::GRAMMAR
    }xms;

    # Did we find any???
    if (/$PERL_WITH_FILTER_BLOCKS/) {

        # Delete all the filters, reporting bad filters, but leaving the line numbers unchanged...
        my $invalid;
        for my $filter (reverse @filters) {
            if ($filter->{INVALID}) {
                substr($_, $filter->{POS}, 0)
                    = qq{BEGIN { die "Invalid filter specification. \Q$filter->{EXPECTED}\E" } };
                $invalid = 1;
            }
            else {
                substr($_, $filter->{POS}, $filter->{LEN}) =~ tr/\n/ /c;
            }
        }
        return if $invalid;

        # Normalize filters...
        for my $filter (@filters) {

            $filter->{RULENAME}  =~ s{ \A (?:Perl)?+ (.*) \z }{Perl$1}xms;
            $filter->{STDNAME}    = $filter->{RULENAME} =~ s{ \A Perl }{PerlStd}xmsr;
            $filter->{REGEX}    //= "(?&$filter->{STDNAME})";
            my $active_regex      = $filter->{REGEX}
                                        =~ s{ \(\?\(DEFINE\) (?>(?&PPR_X_balanced_parens)) \)
                                              $PPR::X::GRAMMAR }{}gxmsr;
            my @captures          = _uniq($active_regex =~ m{ \(\?< \K [^>]++ }gxms);
            $filter->{CAPTURES}   = \@captures;
            $filter->{UNPACK}     = @captures >  1 ? '[@+{'. join(',', map { "'$_'" } @captures) .'}]'
                                  : @captures == 1 ? qq{[\$+{'$captures[0]'}]}
                                  :                  q{[]};
            my $PARAMS            = join ',', map { '$'.$_ } @captures;
            $filter->{HANDLER}    = qq{sub ($PARAMS)}
                                  . _line_comment($_,$filter->{BLOCKPOS},$start_line)
                                  . $filter->{BLOCK};
        }

        # Build progressive regexes for each filter...
        my ($PATTERN, $SELFPATTERN);
        for my $f (keys @filters) {
            my $filter = $filters[$f];

            # The pattern for this filter needs to capture match information...
            $SELFPATTERN = $filter->{REGEX};
            $PATTERN = qq{
                (?<_> $filter->{REGEX} )
                (?{ my \$len = length(\$+{_});
                    push \@Filter::Syntactic::captures, { RULENAME => '$filter->{RULENAME}',
                                                          CAPTURES => $filter->{UNPACK},
                                                          MATCH    => \$+{_},
                                                          POS      => pos() - \$len,
                                                          LEN      => \$len,
                                                          END      => pos(),
                                                        }
                })
            };

            # If this filter extends a current rule, it needs to include the standard syntax...
            if ($filter->{MODE} eq ':extend') {
                $PATTERN     .= qq{ | (?>(?&$filter->{STDNAME})) };
            }

            # The reparsing rule ALWAYS includes the standard syntax...
            # (because it's reparsing partially transformed source code, which may be standard Perl)
            $SELFPATTERN .= qq{ | (?>(?&$filter->{STDNAME})) };

            # Then we wrap it in the appropriately named subrule...
            $PATTERN       = qq{ (?<$filter->{RULENAME}> $PATTERN     ) };
            $SELFPATTERN   = qq{ (?<$filter->{RULENAME}> $SELFPATTERN ) };

            # The filter also needs to recognize any new syntax for any later filters...
            my $SELFEXTRAS = q{};
            for my $next_filter (@filters[$f+1..$#filters]) {
                my $NEXT_PAT = $next_filter->{REGEX};
                   $NEXT_PAT = $next_filter->{MODE} eq ':extend'
                    ? qq{ (?<$next_filter->{RULENAME}> $NEXT_PAT | (?>(?&$next_filter->{STDNAME}))) }
                    : qq{ (?<$next_filter->{RULENAME}> $NEXT_PAT                                  ) };

                $PATTERN    .= $NEXT_PAT;
                $SELFEXTRAS .= $NEXT_PAT;
            }

            # And the filter's version of the full document-parsing regex gets saved in the filter...
            $filter->{FULLREGEX}
                = qq{ \\A (?&PerlEntireDocument)  \\z (?(DEFINE) $PATTERN    ) \$PPR::X::GRAMMAR };
            $filter->{SELFREGEX}
                = qq{ \\A     $SELFPATTERN        \\z (?(DEFINE) $SELFEXTRAS ) \$PPR::X::GRAMMAR };
        }

        # 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 ' => $_prev_under,
                                            ' After filter ' => $_,
                                        );
                                        $_prev_under = $_;
                                    }
                                }
                            } =~ s{}{$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";
                                    }
                                  }
                             );
                        $FIRST_FILTER = 0;
        }

        # Create a final syntax check after all the filters have been applied...
        my $FINAL_CHECK = q{
            if ($_ !~ m{ \A (?>(?&PerlEntireDocument)) \z $PPR::X::GRAMMAR }xms) {
                # Report that the final transformation isn't valid Perl...
                my ($file, $line) = (caller 1)[1,2]; $line--;
                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 $file line $line\n",
                    "\n$diagnostic\n",
                    "(possibly the result of source filtering by " . __PACKAGE__ . " at line $line)\n";
            }
        } =~ s{}{$start_line - 1}gre;

        # If there was more than one filter, debug the final state...
        if (@filters > 1) {
            $FINAL_CHECK .= q{
                Filter::Syntactic::_debug(
                    'Initial source' => $_initial_under, '  Final source' => $_, "final"
                ) if $_debugging;
            }
        }

        # Put the entire source filter together...
        my $FILTER = qq{
            use Filter::Simple;

            FILTER {
                # Handle options...
                my \$_debugging = \@_ && \$_[1] && \$_[1] eq '-debug';
                if (!\$_debugging && \$_[1]) {
                    warn "Unknown option: \$_[1] at " . join(' line ', (caller 1)[1,2]) . "\n";
                }

                # Prep for debugging...
                my \$_prev_under    = \$_;
                my \$_initial_under = \$_;

                # Build filter...
                $LUT;
                $PROC_LOOPS
                $FINAL_CHECK
            } { terminator => "" };
        };

        # Install new filter, adjusting line reporting...
        substr ($_, $filters[0]{POS}//0, 0)
            = $FILTER . _line_comment($_, $filters[0]{POS}, $start_line);
    }
    else {
        # Report syntax error...
        my $error = $PPR::X::ERROR->origin($start_line, $filename);
        my $diagnostic = $error->diagnostic || "syntax error at $filename line " . $error->line;
        $diagnostic .= qq{\nnear: } . ($error->source =~ tr/\n/ /r)  if $diagnostic !~ /, near/;
        die "$diagnostic\n";
    }
} {terminator => ""};

sub _uniq (@list) {
    my %seen;
    return grep {!$seen{$_}++} @list;
}

sub _debug ($pre_label, $pre, $post_label, $post, $is_final = 0) {
    # Set up the (possibly paged) output stream for debugging info...
    state $DBOUT = do {
        my $fh;
        if    ($ENV{DIFFPAGER} && open $fh, "|$ENV{DIFFPAGER}") { $fh      }
        elsif ($ENV{PAGER}     && open $fh, "|$ENV{PAGER}"    ) { $fh      }
        else                                                    { \*STDERR }
    };

    # If we can diff, then diff...
    if (eval { require Text::Diff }) {
        print {$DBOUT} "--- $pre_label\n+++ $post_label\n",
                       Text::Diff::diff(\$pre, \$post) . "\n";
    }

    # Otherwise, just print out each post-transformation source (except the last)...
    elsif (!$is_final) {
        print {$DBOUT} '=====[ '. _trim($post_label) . " ]========================\n\n$post\n";
    }

    # For the last, just rule a line under the previous output (which will be identical)...
    else {
        print {$DBOUT} ('=' x 50), "\n\n";
    }
}

sub _trim ($str) {
    return $str =~ s{^\s+}{}r =~ s{\s*$}{}r;
}

1; # Magic true value required at end of module
__END__