## 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.019'; # VERSION: generated by DZP::OurPkgVersion


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

use Git::Hooks 3.000000;
use Path::Tiny;
use Log::Any qw{$log};
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';

    eval {
        load 'Perl::Critic';
        load 'Perl::Critic::Utils';
        load 'Perl::Critic::Violation';
        1; # To cover the fact that operation correctly returns a false value.
    } or do {
        $log->errorf( __PACKAGE__ . q{::}
            . '_set_critic():Cannot load Perl::Critic'
        );
        return { 'error' => 'Cannot load Perl::Critic' };
    };

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

    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( defined $checker->{'cache'}->{'error'} ) {
                $git->fault($checker->{'name'} . ' Error: ' . $checker->{'cache'}->{'error'});
                ++$errors;
                return $errors;
            }
            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.019

=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

=head2 Additional Dependencies

You need to install separately the dependencies needed
for using different checkers.

=head3 Perl::Critic

=over

=item Perl::Critic

=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 <mikkoi@cpan.org>'

=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
