## no critic (ValuesAndExpressions::RequireInterpolationOfMetachars)

package Git::MoreHooks::CheckPerl;

use strict;
use warnings;
use 5.016000;
use utf8;

# ABSTRACT: Check committed files for Perl::Critic correctness.

our $VERSION = '0.015'; # VERSION: generated by DZP::OurPkgVersion

# use Git::MoreHooks::CheckCommitBase \&do_hook;

use Git::Hooks 2.008000;
use Path::Tiny;
use Log::Any qw{$log};

# use Params::Validate qw(:all);
use Module::Load qw{ load };
use Text::Glob qw{ glob_to_regex };
use List::MoreUtils qw( any );

my $PKG    = __PACKAGE__;
my ($HOOK) = __PACKAGE__ =~ /::([^:]+)$/msx;
my $CFG    = 'githooks.' . $HOOK;

####################
# Hook configuration, check it and set defaults.

sub _setup_config {
    my ($git) = @_;
    $log->debugf( __PACKAGE__ . '::_setup_config(%s):', '$git' );

    my $config = $git->get_config();
    $log->tracef( __PACKAGE__ . '::_setup_config(): Current Git config:\n%s.', $config );

    # Put empty hash if there is no config items.
    $config->{ lc $CFG } //= {};

    # Set default config values.
    my $default = $config->{ lc $CFG };
    $default->{'use-temp-files'} //= [0];
    $default->{'name'}           //= [ '*.p[lm]', '*.psgi', '*.t' ];

    $default->{'critic'} //= {};
    $default->{'b-lint'} //= {};
    $default->{'perl-c'} //= {};

    # Perl::Critic
    $default->{'critic'}->{'active'}  //= ['true'];
    $default->{'critic'}->{'profile'} //= [];

    # B::Lint
    $default->{'b-lint'}->{'active'} //= ['true'];

    # Perl -c
    $default->{'perl-c'}->{'active'} //= [0];

    $log->tracef( __PACKAGE__ . '::_setup_config(): Final Git config:\n%s.', $config );

    return 1;
}

####################
# Internal

use Config::Tiny;

sub _get_critic_profile {
    my ( $git, $profile ) = @_;
    $log->debugf( __PACKAGE__ . q{::} . '_get_critic_profile():profile=%s', $profile );

    my $content = $git->run( qw/cat-file -p/, $profile );
    $log->tracef( __PACKAGE__ . q{::} . '_get_critic_profile():content=%s', $content );

    return $content;
}

sub _read_critic_profile {
    my ( $git, $content ) = @_;
    my $c = Config::Tiny->read_string($content);
    return $c;
}

sub _set_critic {
    my ($git) = @_;
    my $cfg_section = $CFG . q{.} . 'critic';

    my $pc_rc_filename = $git->get_config( $cfg_section => 'profile' );
    $log->tracef( __PACKAGE__ . q{::} . '_set_critic():pc_rc_filename=%s', $pc_rc_filename );

    load 'Perl::Critic';
    load 'Perl::Critic::Violation';
    load 'Perl::Critic::Utils';

    my @critic_cfg_props      = qw( severity theme top only force verbose allow-unsafe );
    my @critic_cfg_list_props = qw( include exclude );
    my %cfg;
    if ($pc_rc_filename) {
        my $content = _get_critic_profile( $git, $pc_rc_filename );
        my $rc      = _read_critic_profile( $git, $content );
        $log->debugf( __PACKAGE__ . q{::} . '_set_critic():(rc)=(%s)', $rc );

        $cfg{'-profile'} = q{};    # Do not read a .perlcriticrc file!
        ## no critic (ControlStructures::ProhibitPostfixControls)
        my $props = $rc->{_};
        $log->debugf( __PACKAGE__ . q{::} . '_set_critic():(props)=%s', $props );
        foreach my $key ( keys %{$props} ) {
            my $item_name = ( any { $key } @critic_cfg_props ) ? "-$key" : $key;
            my $val       = $props->{$key};
            $cfg{$item_name} = $val;
        }

        # These two require special handling.
        foreach my $key (@critic_cfg_list_props) {
            my $val = $props->{$key};
            $cfg{"-$key"} = [ split qr/\s+/msx, $val ] if ($val);    ## no critic (ControlStructures::ProhibitPostfixControls)
        }
    }
    else {
        my $props = $git->get_config("$cfg_section.cfg");
        $log->debugf( __PACKAGE__ . q{::} . '_set_critic():(props)=%s', $props );
        foreach my $key ( keys %{$props} ) {
            my $item_name = ( any { $key } @critic_cfg_props ) ? "-$key" : $key;
            my $val       = $props->{$key}->[-1];                                  # The value is a list, take last item from it.
            $cfg{$item_name} = $val;
        }

        # These two require special handling.
        foreach my $key (@critic_cfg_list_props) {
            my $val = $props->{$key}->[-1];
            $cfg{"-$key"} = [ split qr/\s+/msx, $val ] if ($val);    ## no critic (ControlStructures::ProhibitPostfixControls)
        }
    }
    $log->debugf( __PACKAGE__ . q{::} . '_set_critic():(cfg)=(%s)', \%cfg );

    my $pc = Perl::Critic->new(%cfg);
    $log->debugf( __PACKAGE__ . q{::} . '_set_critic():(Perl::Critic config)=(%s)', $pc->config );

    # set the format to be a comment
    my $verbosity = $pc->config->verbose;
    my $format    = Perl::Critic::Utils::verbosity_to_format($verbosity);
    Perl::Critic::Violation::set_format("# $format");

    return { 'critic' => $pc };
}

sub _check_perl_critic_violations {
    my ( $git, $commit, $cache, $content, $filename ) = @_;

    my ($critic) = $cache->{'critic'};

    # Source code should only be passed to PPI::Document->new as a SCALAR reference
    my @violations = $critic->critique( \$content );
    $log->debugf( __PACKAGE__ . q{::} . '_check_perl_critic_violations():file=%s, violations=%s', $filename, \@violations );

    return @violations;
}

# TODO Make this dynamic, add more checkers.
my @PERL_CHECKERS = (
    {
        name  => q{Perl::Critic},
        cfg   => q{critic},
        f_do  => \&_check_perl_critic_violations,
        input => 'FILE_CONTENT',
        f_pre => \&_set_critic,
        cache => undef,
    }
);

####################
# Main functions

sub check_new_or_modified_files {
    my ( $git, $commit, @files ) = @_;
    $log->debugf( __PACKAGE__ . q{::} . 'check_new_or_modified_files(%s, %s, %s)', 'git', $commit, \@files );
    my $errors = 0;

    my $config = $git->get_config($CFG);
    $log->tracef( __PACKAGE__ . q{::} . 'check_new_or_modified_files():config=%s', $config );
    my @name_patterns;
    foreach my $pattern ( @{ $config->{'name'} } ) {

        # TODO Refactor regex.
        ## no critic (RegularExpressions::RequireDotMatchAnything)
        ## no critic (RegularExpressions::RequireExtendedFormatting)
        ## no critic (RegularExpressions::RequireLineBoundaryMatching)
        if ( $pattern =~ m/^qr(.)(.*)\g{1}/ ) {
            $pattern = qr/$2/;
        }
        else {
            $pattern = glob_to_regex($pattern);
        }
        push @name_patterns, $pattern;
    }
    $log->debugf( __PACKAGE__ . q{::} . 'check_new_or_modified_files():name_patterns=%s', \@name_patterns );
    foreach my $file ( $git->run( qw/ls-files -s/, @files ) ) {
        my ( $mode, $sha, $n, $filename ) = split q{ }, $file;
        $log->tracef( __PACKAGE__ . q{::} . 'check_new_or_modified_files():(mode, sha, n, name)=(%s, %s, %s, %s)',
            ( $mode, $sha, $n, $filename ) );
        my $basename = path($filename)->basename;
        $log->debugf( __PACKAGE__ . q{::} . 'check_new_or_modified_files():basename=%s', $basename );

        # The regexes generated from globs might not be /msx compatible.
        ## no critic (RegularExpressions::RequireDotMatchAnything)
        ## no critic (RegularExpressions::RequireExtendedFormatting)
        ## no critic (RegularExpressions::RequireLineBoundaryMatching)
        next if ( !any { $basename =~ m/$_/ } @name_patterns );
        my $content = $git->run( qw/cat-file -p/, $sha );
        $log->tracef( __PACKAGE__ . q{::} . 'check_new_or_modified_files():content=%s', $content );

        foreach my $checker (@PERL_CHECKERS) {
            $log->debugf( __PACKAGE__ . q{::} . 'check_new_or_modified_files():checker=%s', $checker );
            my @violations;
            my $active = $config->{'critic'}->{'active'}->[0];
            $log->debugf( __PACKAGE__ . q{::} . 'check_new_or_modified_files():active=%s', $active );
            next if ( !$active );

            if ( !defined $checker->{'cache'} ) {
                $checker->{'cache'} = &{ $checker->{'f_pre'} }($git);
            }
            if ( $checker->{'input'} eq q{FILE_CONTENT} ) {
                @violations = &{ $checker->{'f_do'} }( $git, $commit, $checker->{'cache'}, $content, $filename );
            }
            else {
                # TODO Save file to /tmp dir. Not implemented!
            }
            $log->debugf( __PACKAGE__ . q{::} . 'check_new_or_modified_files():file=%s, violations=%s', $filename, \@violations );

            # Report errors
            foreach my $violation (@violations) {
                $git->fault( $checker->{'name'} . " error in file '$filename':\n" . $violation,
                    { prefix => 'CheckPerl', commit => $commit } );
                ++$errors;
            }
        }
    }
    return $errors;
}

sub check_commit {
    my ($git) = @_;
    return check_new_or_modified_files( $git, ':0', $git->filter_files_in_index('AM') );
}

sub check_ref {
    my ( $git,        $ref )        = @_;
    my ( $old_commit, $new_commit ) = $git->get_affected_ref_range($ref);
    return check_new_or_modified_files( $git, $new_commit, $git->filter_files_in_range( 'AM', $old_commit, $new_commit ), );
}

sub check_patchset {
    my ( $git, $branch, $commit ) = @_;
    return check_everything( $git, $branch, $commit->commit, $commit->extra );
}

# Install hooks
my $options = { config => \&_setup_config };

GITHOOKS_CHECK_PRE_COMMIT( \&check_commit, $options );
GITHOOKS_CHECK_AFFECTED_REFS( \&check_ref, $options );
GITHOOKS_CHECK_PATCHSET( \&check_patchset, $options );

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Git::MoreHooks::CheckPerl - Check committed files for Perl::Critic correctness.

=head1 VERSION

version 0.015

=head1 SYNOPSIS

Use package via
L<Git::Hooks>
interface (git config file).

=head1 DESCRIPTION

This plugin allows user to check committed Perl files
with different static analysis tools for Perl source code.
Currently supported is only L<Perl::Critic>.
Future support is planned for L<B::Lint> and running
syntax check command F<perl -c>.

There are other ways to run Perl::Critic, such as simply running
the executable F<perlcritic>. This hook runs Perl::Critic within
the same Git::Hooks process and therefore uses the same Perl
installation and its modules. It saves you from starting a new
process for every file you check, and you can install the policies
together with everything else Git::Hooks needs.

In the case of server side repo,
this hook takes content of the new or modified files directly
from Git and passes them to Perl::Critic without writing them
to a temporary dir only for F<perlcritic> to read them again.

=head1 STATUS

Package Git::MoreHooks is currently being developed so changes in the existing hooks are possible.

=for Pod::Coverage check_commit_at_client check_commit_at_server

=for Pod::Coverage check_ref

=head1 USAGE

To enable CheckPerl plugin, you need
to add it to the githooks.plugin configuration option:

    git config --add githooks.plugin Git::MoreHooks::CheckPerl

This plugin hooks itself to the following hooks:

=for :comment The following hooks are associated to Hook Driver GITHOOKS_CHECK_PRE_COMMIT.

=over

=item * B<pre-commit>

This hook is invoked during the commit.

=item * B<pre-applypatch>

This hook is invoked during the email-based workflow after a patch
is applied but before a commit is made.

=back

=for :comment The following hooks are associated to Hook Driver GITHOOKS_CHECK_AFFECTED_REFS.

=over

=item * B<commit-received>

This hook is invoked when a commit is received by Gerrit either
by direct push or by push for review (to refs/for/branch). It
allows a push to be rejected before a review is created, or before
the branch is updated in case of a direct push.
It is called once for each commit in the push.

=item * B<pre-receive>

This hook is invoked once in the remote repository during C<git push>.

=item * B<ref-update>

This hook is invoked when a push request is received by Gerrit Code
Review.

=item * B<submit>

This is called when a user attempts to submit a change in Gerrit.
It allows the submit to be rejected.

=item * B<update>

This hook is invoked multiple times in the remote repository during
C<git push>, once per branch being updated.

=back

=for :comment The following hooks are associated to Hook Driver GITHOOKS_CHECK_PATCHSET.

=over

=item * B<draft-published>

The B<draft-published> hook is executed when the user publishes a draft
change, making it visible to other users.

=item * B<patchset-created>

The B<patchset-created> hook is executed asynchronously when a user
performs a push to one of Gerrit's virtual branches (refs/for/*) in
order to record a new review request.

=back

=head1 CONFIGURATION

This plugin is configured by the following git options.

=head3 githooks.checkperl.use-temp-files BOOL

Whenever a checker supports it, files are not written
to a temporary folder for checking. Instead they are extracted
from Git and fed directly as scalar variables to a checker
tool. If you want the checkers to read a file instead,
set this config item to "1". Default is "0".

B<N.B. This config option is not yet implemented>!

=head3 githooks.checkperl.name PATTERN

Use regexp or glob values to specify file patterns.
This item uses same pattern as L<Git::Hooks::CheckFile>
config item F<name>, but without the command.

Only the file's basename is matched against PATTERN.
(Paths are not supported.)
You can set name one or more times.

PATTERN is usually expressed with
L<globbing|https://metacpan.org/pod/File::Glob> to match files based on
their extensions, for example:

    [githooks "checkperl"]
        name = *.pl

If you need more power than globs can provide you can match using
L<regular expressions|http://perldoc.perl.org/perlre.html>, using the C<qr//>
operator, for example:

    [githooks "checkperl"]
        name = qr/xpto-\\d+.pl/

Default values are:

    [githooks "checkperl"]
        name = *.p[lm]
        name = *.psgi
        name = *.t

=head3 githooks.checkperl.critic.active BOOL

Activate or deactivate Perl::Critic check.
Set this to false ("0") if you only want to use the other
checkers.
Default is true ("1").

=head3 githooks.checkperl.critic.profile REF_AND_FILENAME

If you have committed a Perl::Critic configuration file (profile)
to the repo, you can specify here where it is.
There is no default value.
The value must have the following pattern: "<ref name>:<file name>".
E.g.

    [githooks "checkperl.critic"]
        profile = refs/heads/master:.perlcriticrc

It is not possible for this hook to simply use the current
F<.perlcriticrc> file in the repo and the currently active branch
for security reasons.

If this item is not set, Perl::Critic is started with its own
default values. It will not read the currently
present F<.perlcriticrc> file even if available.

=head3 githooks.checkperl.critic.cfg HASH

You can alternatively set all the values
in the configuration but if B<profile> is set, they are ignored.

Please consult to
L<Perl::Critic|Perl::Critic/"CONSTRUCTOR">
for further information.

All the values in this section will be used when providing
the configuration to Perl::Critic, including properties
which Perl::Critic does not use but which are used
to configure individual policies.

E.g.

    [githooks "checkperl.critic.cfg"]
        severity     = brutal
        verbose      = 11
        allow-unsafe = 0

B<N.B. This config option is not yet implemented>!

=head1 EXPORTS

This module exports the following routines that can be used directly
without using all of Git::Hooks infrastructure.

=head2 check_commit GIT

This is the routine used to implement the C<pre-commit> hook. It needs
a C<Git::More> object.

=head2 check_affected_refs GIT, REF

This is the routing used to implement the C<update> and the
C<pre-receive> hooks. It needs a C<Git::More> object and the name
of the reference affected by the current push command.

=head2 check_patchset GIT, HASH

This is the routine used to implement the C<patchset-created> Gerrit
hook. It needs a C<Git::More> object and the hash containing the
arguments passed to the hook by Gerrit.

=head1 SEE ALSO

=over

=item L<Git::Hooks>

=item L<Perl::Critic>

=item Alternative way to use Perl::Critic with Git::Hooks package: L<Git::Hooks::CheckFile|Git::Hooks::CheckFile/"CONFIGURATION">.

=back

=head1 NOTES

Thanks go to Gustavo Leite de Mendonça Chaves for his
L<Git::Hooks> package.

=head1 SUBROUTINES/METHODS

=for Pod::Coverage check_new_or_modified_files

=head1 AUTHOR

'Mikko Koivunalho <mikko.koivunalho@iki.fi>'

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2022 by Mikko Koivunalho.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut
