view release on metacpan or  search on metacpan

lib/Perl/Critic/Policy/CodeLayout/RequireTidyCode.pm  view on Meta::CPAN

        {
            name            => 'perltidyrc',
            description     => 'The Perl::Tidy configuration file to use, if any.',
            default_string  => undef,
        },
    );
}

sub default_severity { return $SEVERITY_LOWEST      }
sub default_themes   { return qw(core pbp cosmetic) }
sub applies_to       { return 'PPI::Document'       }

#-----------------------------------------------------------------------------

sub initialize_if_enabled {
    my ($self, undef) = @_;

    # Set configuration if defined
    if (defined $self->{_perltidyrc} && $self->{_perltidyrc} eq $EMPTY) {
        my $rc = $EMPTY;
        $self->{_perltidyrc} = \$rc;
    }

    return $TRUE;
}

#-----------------------------------------------------------------------------

sub violates {
    my ( $self, $elem, $doc ) = @_;

    # Perl::Tidy seems to produce slightly different output, depending
    # on the trailing whitespace in the input.  As best I can tell,
    # Perl::Tidy will truncate any extra trailing newlines, and if the
    # input has no trailing newline, then it adds one.  But when you
    # re-run it through Perl::Tidy here, that final newline gets lost,
    # which causes the policy to insist that the code is not tidy.
    # This only occurs when Perl::Tidy is writing the output to a
    # scalar, but does not occur when writing to a file.  I may
    # investigate further, but for now, this seems to do the trick.

    my $source = $doc->serialize();
    $source =~ s{ \s+ \Z}{\n}xms;

    # Remove the shell fix code from the top of program, if applicable
    ## no critic (ProhibitComplexRegexes)
    my $shebang_re = qr< [#]! [^\015\012]+ [\015\012]+ >xms;
    my $shell_re   = qr<eval [ ] 'exec [ ] [^\015\012]* [ ] \$0 [ ] \$[{]1[+]"\$@"}'
                        [ \t]*[\012\015]+ [ \t]* if [^\015\012]+ [\015\012]+ >xms;
    $source =~ s/\A ($shebang_re) $shell_re /$1/xms;

    my $dest    = $EMPTY;
    my $stderr  = $EMPTY;


    # Perl::Tidy gets confused if @ARGV has arguments from
    # another program.  Also, we need to override the
    # stdout and stderr redirects that the user may have
    # configured in their .perltidyrc file.
    # Also override -b because we are using dest and source.
    local @ARGV = qw(-nst -nse -nb);

    # Trap Perl::Tidy errors, just in case it dies
    my $eval_worked = eval {

        # Beginning with version 20120619, Perl::Tidy modifies $source. So we
        # make a copy so we can get a good comparison after tidying. Doing an
        # s/// on $source after the fact appears not to work with previous
        # versions of Perl::Tidy.
        my $source_copy = $source;

        # In version 20120619 (and possibly earlier), Perl::Tidy assigns the
        # stderr parameter directly to *STDERR.  So when our $stderr goes out
        # of scope, the handle gets closed.  Subsequent calls to warn() will
        # then cause a fatal exception.  See RT #78182 for more details.  In
        # the meantime, we workaround it by localizing STDERR first.
        local *STDERR = \*STDERR;

        # Perl::Tidy 20120619 doesn't accept a scalar ref or a glob ref
        open my $handle, '>', \$stderr
            or throw_generic "error opening scalar: $OS_ERROR";
        $handle = *{$handle}{IO};


        Perl::Tidy::perltidy(
            source      => \$source_copy,
            destination => \$dest,
            stderr      => $handle,
            defined $self->{_perltidyrc} ? (perltidyrc => $self->{_perltidyrc}) : (),
        );

        close $handle or throw_generic "Failed to close in memory file: $OS_ERROR";

        1;
    };

    if ($stderr or not $eval_worked) {
        # Looks like perltidy had problems
        return $self->violation( 'perltidy had errors!!', $EXPL, $elem );
    }

    if ( $source ne $dest ) {
        return $self->violation( $DESC, $EXPL, $elem );
    }

    return;    #ok!
}

1;

#-----------------------------------------------------------------------------

__END__

=pod

=for stopwords perltidy

=head1 NAME

Perl::Critic::Policy::CodeLayout::RequireTidyCode - Must run code through L<perltidy|perltidy>.