File Coverage

blib/lib/Acme/Pythonic.pm

Criterion	Covered	Total	%
statement	90	90	100.0
branch	55	56	98.2
condition	21	21	100.0
subroutine	11	11	100.0
pod	0	6	0.0
total	177	184	96.2

package Acme::Pythonic;

# Please, if you tested it in some earlier version of Perl and works let
# me know! The versions of Filter::Simple, Text::Tabs, and Test::More
# would be useful as well.
use 5.006_001;
use strict;
use warnings;

our ($VERSION, $DEBUG, $CALLER);
$VERSION = '0.47';

use Text::Tabs;

sub import {
    my ($package, %cfg) = @_;
    $DEBUG = $cfg{debug};
    $CALLER = caller() # to be able to check sub prototypes
}


use Filter::Simple;
FILTER_ONLY code => sub {
    unpythonize();
    cuddle_elses_and_friends();
    if ($DEBUG) {
        s/$Filter::Simple::placeholder/BLANKED_OUT/g;
        print;
        $_ = '1;';
    }
};


# This regexp matches a 7-bit ASCII identifier. We use atomic grouping
# because an identifier cannot be backtracked.
my $id = qr/(?>[_a-zA-Z](?:[_a-zA-Z0-9']|::)*)/;

# Shorthand to put an eventual trailing comment in some regexps.
my $tc = qr/(?


# Tries its best at converting Pythonic code to Perl.
sub unpythonize {
    # Sometimes Filter::Simple adds newlines blanking out stuff, which
    # interferes with Pythonic conventions.
    my %bos = (); # BlanketOutS
    my $count = 0;
    s<$Filter::Simple::placeholder>

      $bos{$bo} = $&;
      $bo>geo;

    # In addition, we can now normalize newlines without breaking
    # Filter::Simple's identifiers.
    normalize_newlines();
    my @lines = split /\n/;
    return unless @lines;

    # If unsure about the ending indentation level, add an extra
    # non-indented line to ensure the stack gets emptied.
    push @lines, '1; # added by Acme::Pythonic' if $lines[-1] =~ /^(?:\s|\s*#)/;

    my ($comment,             # comment in the current line, if any
        $indent,              # indentation of the current logical line
        $id_at_sob,           # identifier at StartOfBlock, for instance "else", or "eval"
        $prev_line_with_code, # previous line with code
        $might_be_modifier,   # flag: current logical line might be a modifier
        $line_with_modifier,  # physical line which started the current modifier
        $joining,             # flag: are we joining lines?
        $unbalanced_paren,    # flag: we opened a paren that remains to be closed
        @stack,               # keeps track of indentation stuff
    );

    @stack = ();
    foreach my $line (@lines) {
        # We remove any trailing comment so that we can assert stuff
        # easily about the end of the code in this line. It is later
        # appended back in the continue block below.
        $comment = $line =~ s/(\s*$tc)//o ? $1 : '';
        next if $line =~ /^\s*$/;

        if (!$joining) {
            $unbalanced_paren = left_parenthesize($line);
            $might_be_modifier = $line =~ /^\s*(?:if|unless|while|until|for|foreach)\b/;
            $line_with_modifier = \$line if $might_be_modifier;
            ($indent) = $line =~ /^(\s*)/;
            $indent = length(expand($indent));
        }

        if ($line =~ /(?:,|=>)\s*$/ || $line =~ s/\\\s*$//) {
            ++$joining;
            next if $joining > 1; # if 1 we need yet to handle indentation
        } else {
            $joining = 0;
        }

        # Handle trailing colons, which can be Pythonic, mark a labeled
        # block, mean some map, or &-sub call, etc.
        #
        # We check the parity of the number of ending colons to try to
        # avoid breaking things like
        #
        #    print for keys %main::
        #
        my $bracket_opened_by = '';
        if ($line =~ /(:+)$/ && length($1) % 2) {
            $might_be_modifier = 0;
            # We perform some checks because labels have to keep their colon.
            if ($line !~ /^\s*$id:$/o ||
                $line =~ /[[:lower:]]/ || # labels are not allowed to have lower-case letters
                $line =~ /^\s*(?:BEGIN|CHECK|INIT|END):$/) {
                chop $line;
                if ($unbalanced_paren) {
                    $line .= ")";
                    $unbalanced_paren = 0;
                } else {
                    ($bracket_opened_by) = $line =~ /($id)\s*$/o;
                }
            }
        } elsif (!$joining) {
            $$line_with_modifier =~ s/\(// if $might_be_modifier;
            $unbalanced_paren = 0;
            $line .= ';';
        }

        # Handle indentation. Language::Pythonesque was the basis of
        # this code.
        my $prev_indent = @stack ? $stack[-1]{indent} : 0;
        if ($prev_indent < $indent) {
            push @stack, {indent => $indent, id_at_sob => $id_at_sob};
            $$prev_line_with_code .= " {" unless $$prev_line_with_code =~ s/(?=\s*$tc)/ {/o;
        } elsif ($prev_indent > $indent) {
            do {
                my $prev_id_at_sob = $stack[-1]{id_at_sob};
                pop @stack;
                $prev_indent = @stack ? $stack[-1]{indent} : 0;
                $$prev_line_with_code .= "\n" . ((' ' x $prev_indent) . "}");
                $$prev_line_with_code .= ";" if needs_semicolon($prev_id_at_sob);
            } while $prev_indent > $indent;
            $$prev_line_with_code =~ s/;$/ / if $might_be_modifier;
        }
        $id_at_sob = $bracket_opened_by;
    } continue {
        $line =~ s/^\s*pass;?\s*$//;
        $prev_line_with_code = \$line if !$joining && $line =~ /\S/;
        $line .= $comment;
    }

    $_ = join "\n", @lines;
    s/$;BLANKED_OUT_\d+$;/$bos{$&}/go;
}


# In the trials I've done seems like the Python interpreter understands
# any of the three conventions, even if they are not the ones in the
# platform, and even if they are mixed in the same file.
#
# In addition, it guarantees make test works no matter the platform.
sub normalize_newlines {
    s/\015\012/\n/g;
    tr/\015/\n/ unless "\n" eq "\015";
    tr/\012/\n/ unless "\n" eq "\012";
}


# Put an opening paren in the places we forgive parens. It will be later
# closed or removed as needed in the main subroutine.
sub left_parenthesize {
    $_[0] =~ s/^(\s*\b(?:if|elsif|unless)\b\s*)/$1(/                                      ||
    $_[0] =~ s/^(\s*(?:$id\s*:)?\s*\b(?:while|until)\b(\s*))/$2 eq '' ? "$1 (" : "$1("/eo ||
    $_[0] =~ s/^(\s*(?:$id\s*:\s*)?\bfor(?:each)?\b\s*)(.*)/fortype_guesser($1,$2)/oxe
}


# Tries its best at guessing a for(each) type or, at least, where to put
# the opening paren.
#
# Returns a string which is a copy of the original with the paren
# inserted.
sub fortype_guesser {
    my ($for, $rest) = @_;
    my $guess = "";

    # Try to match "for VAR in LIST", and "for VAR LIST"
    if ($rest =~ m/^((?:my|our)? \s* \$ $id\s+) in\s* ((?: (?:[\$\@%&\\]) | (?:\b\w) ) .*)$/ox ||
        $rest =~ m/^((?:my|our)? \s* \$ $id\s*)       ((?: (?:[\$\@%&\\]) | (?:\b\w) ) .*)$/ox) {
        $guess = "$for$1($2";
    } else {
        # We are not sure whether this is a for or a foreach, but it is
        # very likely that putting parens around gets it right.
        $rest =~ s/^\s*in\b//; # fixes "foreach in LIST"
        $guess = "$for($rest";
    }

    return $guess;
}


# Guesses whether a block started by $id_at_sob needs a semicolon after the
# ending bracket.
sub needs_semicolon {
    my $id_at_sob = shift;
    return 0 if !$id_at_sob;
    return 1 if $id_at_sob =~ /^(do|sub|eval)$/;

    my $proto = $id_at_sob =~ /::/ ? prototype($id_at_sob) : prototype("${CALLER}::$id_at_sob");
    return 0 if not defined $proto;
    return $proto =~ /^;?&$/;
}


# We follow perlstyle here, as we did until now.
sub cuddle_elses_and_friends {
    s/^([ \t]*})\s*(?=(?:elsif|else|continue)\b)/$1 /gm;
    s/^([ \t]*})\s*(?=(?:if|unless|while|until|for|foreach)\b(?!.*{$tc?$))/$1 /gm;
}

1;


__END__