#!/trw/local/perl/default/bin/perl 

use 5.006001;

use strict;
use warnings;

use Encode;         # First released in 5.7.3.
use Encode::Guess;  # First released in 5.8.0.
use English qw{ -no_match_vars };
use Getopt::Long 2.33 qw{ :config auto_version };
use Perl::Critic;
use Perl::Critic::Utils qw{ all_perl_files };
use Perl::Critic::Violation;
# The following is superfluous as far as Perl::Critic is concerned, but
# handy if we want to run the debugger.
use Perl::Critic::Policy::ValuesAndExpressions::ProhibitFiletest_rwxRWX;
use PPI::Document;
use Readonly;
use Pod::Usage;

our $VERSION = '0.000_901';

Readonly::Scalar my $DEFAULT_SINGLE_FILE_FORMAT => 4;
Readonly::Scalar my $DEFAULT_MULTI_FILE_FORMAT  => 5;

my %opt;

GetOptions( \%opt,
    'format=s'  => \( my $format ),
    'suspect_encoding|suspect-encoding=s@' => \( my @suspect ),
    'verbose!'  => \( my $verbose ),
    help => sub { pod2usage( { -verbose => 2 } ) },
) or pod2usage( { -verbose => 0 } );

if ( @suspect ) {
    @suspect = map { split qr< \s* , \s* >smx } @suspect;
} else {
    @suspect = qw{ iso-latin-1 };
}

if ( ! @ARGV ) {
    -e 'MANIFEST'
        or die "No arguments specified and no MANIFEST found\n";
    require ExtUtils::Manifest;
    my $manifest = ExtUtils::Manifest::maniread();
    @ARGV = sort all_perl_files( keys %{ $manifest } )  ## no critic (RequireLocalizedPunctuationVars)
}

my $critic = Perl::Critic->new(
    -profile    => 'NONE',
);

$critic->add_policy(
    -policy => 'ValuesAndExpressions::ProhibitFiletest_rwxRWX',
    -config => \%opt
);

{
    no warnings qw{ newline };  ## no critic (ProhibitNoWarnings)
    Perl::Critic::Violation::set_format(
        defined $format ? $format :
        ( @ARGV > 1 || -d $ARGV[0] ) ?
            $DEFAULT_MULTI_FILE_FORMAT :
            $DEFAULT_SINGLE_FILE_FORMAT
    );
}

foreach my $fn ( @ARGV ) {

    no warnings qw{ newline };  ## no critic (ProhibitNoWarnings)
    foreach my $pf ( -e $fn ? all_perl_files( $fn ) : \$fn ) {

        # We jump through this particular hoop because PPI::Document
        # does not recognize 'use utf8;'. Instead it looks for a Byte
        # Order Mark (a.k.a. non-breaking space) as the first encoded
        # character of the file, and adjusts accordingly. UTF-8 files
        # without a BOM are therefore not read correctly. So we incur
        # the overhead of guessing and decoding if we guess a unique
        # encoding. We then feed PPI::Document the possibly-decoded file
        # content.
        my $doc;
        {
            local $/ = undef;
            open my $fh, '<', $pf
                or die "Unable to open $pf: $!\n";
            my $data = <$fh>;
            close $fh;

            my $enc = guess_encoding( $data, @suspect );
            ref $enc
                and $data = $enc->decode( $data );
            # warn "Debug - $pf encoding: ", ref $enc ? $enc->name() : $enc;

            $doc = eval { PPI::Document->new( \$data ) }
                or do {
                warn "In $pf, @{[ PPI::Document->errstr() ]}\n";
                next;
            };
        }


        # DANGER WILL ROBINSON! ENCAPSULATION VIOLATION!
        # There is no supported way to associate a file name with a
        # PPI::Document created from file content rather than file name.
        # After considering monkey-patching the filename() method, I
        # went with just hammering the name into the hash, which has the
        # advantage of being straightforward. A solid monkey-patch
        # implementation needs inside-out objects so it can fall back to
        # the original implementation of filename() if an overridden
        # file name is not present.
        ref $pf
            or $doc->{filename} = $pf;

        my @violations = Perl::Critic::Violation::sort_by_location(
            $critic->critique( $doc ) );

        if ( @violations ) {
            foreach ( @violations ) {
                print;
            }
        } elsif ( $verbose ) {
            local $_ = Perl::Critic::Violation::get_format();
            local $OUTPUT_RECORD_SEPARATOR = "\n";
            print m/ (?: \A | (?<= [^%] ) ) (?: %% )* %f /smx ?
                "$pf source OK" : 'source OK';
        }
    }
}

__END__

=head1 NAME

old-prototypes - Find old-style prototypes

=head1 SYNOPSIS

 old-prototypes .
 old-prototypes lib/
 old-prototypes -help
 old-prototypes -version

=head1 OPTIONS

The following options are accepted by this script. They are documented
with leading double dashes, but single dashes are accepted, as are
unique abbreviations.

=head2 --format

 --format 5

This option specifies the F<perlcritic> format to use for output. This
corresponds to the F<perlcritic> C<--verbose> option, takes the same
values, and has the same default.

=head2 --help

This option displays the documentation for this script. The script then
exits.

=head2 --suspect-encoding

 --suspect-encoding latin-5

This option specifies encodings to suspect over and above C<ASCII> and
the C<UTF> encodings. The value is the names (or aliases) of one or more
encodings as a comma-delimited string. This option can be specified more
than once.

The heavy lifting here is done by L<Encode::Guess|Encode::Guess>, whose
L<CAVEATS|Encode::Guess/CAVEATS> cautions against specifying too many
encodings.

If no encoding can be determined for a file, or if more than one
encoding works for a file, the un-decoded input is fed to
L<PPI::Document|PPI::Document>.

The default is C<--suspect-encoding=iso-8859-1>.

=head2 --verbose

If this Boolean option is asserted, files that have no violations are
displayed as C<'OK'>. If not, files having no violations produce no
output.

=head2 --version

This option displays the version of this script. The script then exits.

=head1 DESCRIPTION

This Perl script wraps the rogue Perl::Critic policy
ValuesAndExpressions::ProhibitFiletest_rwxRWX.

If no arguments are passed, the contents of the F<MANIFEST> are scanned
-- at least, those which appear to be Perl files.

If an argument is passed which is not a file name, it is assumed to be
code to critique.

=head1 AUTHOR

Thomas R. Wyant, III F<wyant at cpan dot org>

=head1 COPYRIGHT

Copyright (C) 2022 by Thomas R. Wyant, III

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the directory LICENSES.

This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.

=cut

# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 72
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=72 ft=perl expandtab shiftround :
