view release on metacpan or  search on metacpan

t/githook-perltidy.t  view on Meta::CPAN

use strict;
use warnings;
use Carp qw/croak/;
use File::Copy;
use FindBin qw/$Bin/;
use Path::Tiny;
use Perl::Tidy;
use Pod::Tidy;
use Sys::Cmd qw/run/;
use Test::Fatal;
use Test::More;
use Test::TempDir::Tiny;
use Time::Piece;

my $sweetened = eval { require Perl::Tidy::Sweetened };
my $critic    = eval { require Perl::Critic };

plan skip_all => 'No Git' unless eval { run(qw!git --version!); 1; };

my $pre_commit       = path( '.git', 'hooks', 'pre-commit' );
my $srcdir           = path( $Bin,   'src' );
my $githook_perltidy = path( $Bin,   'githook-perltidy' );

my $pod_opts = {};

foreach my $line ( $srcdir->child('podtidy-opts')->lines ) {
    chomp $line;
    $line =~ s/^--//;
    my ( $opt, $arg ) = split / /, $line;
    $pod_opts->{$opt} = $arg;
}

sub copy_src {
    my $file = shift || die 'copy_src($FILE, $dest)';
    my $dest = shift || die 'copy_src($file, $DEST)';
    copy( $srcdir->child($file), $dest ) or die "copy: $!";

    return if $dest =~ m/^\./;
    my $errormsg;

    if ( -e '.perltidyrc' ) {
        if ( -e '.podtidy-opts' ) {
            copy( $dest, $dest . '.perlpodtidy' ) or die "copy: $!";

            Perl::Tidy::perltidy(
                argv       => [ qw{-nst -b -bext=/}, "$dest.perlpodtidy" ],
                errorfile  => \$errormsg,
                perltidyrc => $srcdir->child('perltidyrc')->stringify,
            );

            Pod::Tidy::tidy_files(
                files     => [ $dest . '.perlpodtidy' ],
                recursive => 0,
                verbose   => 0,
                inplace   => 1,
                nobackup  => 1,
                columns   => 72,
                %$pod_opts,
            );
        }
        else {
            copy( $dest, $dest . '.perltidy' ) or die "copy: $!";

            Perl::Tidy::perltidy(
                argv       => [ qw{-nst -b -bext=/}, "$dest.perltidy" ],
                errorfile  => \$errormsg,
                perltidyrc => $srcdir->child('perltidyrc')->stringify,
            );
        }
    }
    elsif ( -e '.perltidyrc.sweetened' and $sweetened ) {
        if ( -e '.podtidy-opts' ) {
            copy( $dest, $dest . '.perlspodtidy' ) or die "copy: $!";

            Perl::Tidy::Sweetened::perltidy(
                argv       => [ qw{-nst -b -bext=/}, "$dest.perlspodtidy" ],
                errorfile  => \$errormsg,
                perltidyrc => $srcdir->child('perltidyrc')->stringify,
            );

            Pod::Tidy::tidy_files(
                files     => [ $dest . '.perlspodtidy' ],
                recursive => 0,
                verbose   => 0,
                inplace   => 1,
                nobackup  => 1,
                columns   => 72,
                %$pod_opts,
            );
        }
        else {
            copy( $dest, $dest . '.perlstidy' ) or die "copy: $!";

            Perl::Tidy::Sweetened::perltidy(
                argv       => [ qw{-nst -b -bext=/}, "$dest.perlstidy" ],
                errorfile  => \$errormsg,
                perltidyrc => $srcdir->child('perltidyrc')->stringify,
            );
        }
    }

    if ( -e '.podtidy-opts' ) {
        copy( $dest, $dest . '.podtidy' ) or die "copy: $!";

        Pod::Tidy::tidy_files(
            files     => [ $dest . '.podtidy' ],
            recursive => 0,
            verbose   => 0,
            inplace   => 1,
            nobackup  => 1,
            columns   => 72,
            %$pod_opts,
        );
    }
}

sub add_commit {
    my $file = shift || die 'add_commit($FILE)';

    run( qw!git add!,       $file );
    run( qw!git commit -m!, 'add ' . $file );

    return 1;
}

sub is_file {
    my $f1   = shift || die 'is_file($F1, $f2, $test)';
    my $f2   = shift || die 'is_file($f1, $F2, $test)';
    my $test = shift || die 'is_file($f1, $f2, $TEST)';

    is path($f1)->slurp_raw, path($f2)->slurp_raw, $test;
}

my $test = localtime->datetime;

in_tempdir $test => sub {
    my $tmpdir = shift;

    note "tidy: $githook_perltidy";
    note "tempdir: $tmpdir";

    like exception { run($githook_perltidy) }, qr/^usage:/,
      'usage needs an argument';

    run(qw!git init --initial-branch=main!);
    run( qw!git config user.email!, 'you@example.com' );
    run( qw!git config user.name!,  'Your Name' );

    like exception { run( $githook_perltidy, qw!install! ) },
      qr/\.perltidyrc/, 'no .perltidyrc';

    copy_src( 'perltidyrc', '.perltidyrc' );

    like exception { run( $githook_perltidy, qw!install! ) },
      qr/\.perltidyrc/, '.perltidyrc uncommitted';

    add_commit('.perltidyrc');

    ok !-e $pre_commit, 'pre-commit not in place yet';
    like run( $githook_perltidy, qw!install! ), qr/pre-commit/s,
      'install output';

    ok -e $pre_commit, 'pre-commit installed';

    like exception { run( $githook_perltidy, qw!install! ) },
      qr/exists/, 'existing hook files';

    like run( $githook_perltidy, qw!install --force! ),
      qr/pre-commit \(forced\)/s, 'install --force';