dev-precommit

#!/usr/bin/perl
use strict;
use warnings;
use local::lib;
use v5.10;

use Cwd qw( abs_path );
use File::Basename qw( basename );
use File::Find qw( find );
use FindBin qw( $RealBin );
use List::Util qw( any );
use Mojo::File   ();
use Perl::Critic ();
use Perl::Tidy   ();

$| = 1;

# tabs

find(
    sub {
        return unless -f $File::Find::name && -s $File::Find::name;
        my $file = substr($File::Find::name, 2);
        return if $file =~ m{/} && $file !~ m{^(?:lib|web)/};
        return if basename($file) =~ /^\./ || $file =~ /\.(bak|swp|png|ttf)$/;
        return if $file eq 'makefile';

        my $content = Mojo::File->new("$RealBin/$file")->slurp();
        return unless $content =~ /\t/;
        say "\e[31m$file contains tabs\e[0m";
    },
    '.'
);

# tidy sass (sort selectors)

foreach my $file (glob('web/*.sass')) {
    print $file;

    if (!is_modified($file)) {
        say ' unchanged';
        next;
    }

    my @original = split(/\n/, Mojo::File->new($file)->slurp());
    my @output;
    my $chunk = {};

    reset_chunk($chunk);
    foreach my $line (@original) {
        my $indent = $line =~ /^(\s+)/ ? length($1) : 0;

        if ($line eq '') {
            push @output, process_chunk($chunk);
            push @output, '';
            $chunk->{indent} = $indent;
            next;
        }

        if ($indent != $chunk->{indent}) {
            push @output, process_chunk($chunk);
            $chunk->{indent} = $indent;
            push @{ $chunk->{lines} }, $line;
            next;
        }

        push @{ $chunk->{lines} }, $line;
    }
    push @output, process_chunk($chunk);

    sub reset_chunk {
        my ($ch) = @_;
        $ch->{indent} = -1;
        $ch->{lines}  = [];
    }

    sub process_chunk {
        my ($ch) = @_;
        my @lines =
            sort {
            return -1 if $a =~ m{^\s*//};
            return 1  if $b =~ m{^\s*//};
            return $a cmp $b;
            } @{ $ch->{lines} };
        reset_chunk($ch);
        return @lines;
    }

    my $original = join("\n", @original) . "\n";
    my $output   = join("\n", @output) . "\n";
    if ($original ne $output) {
        say " \e[34mupdated\e[0m";
        Mojo::File->new($file)->spurt($output);
    } else {
        say ' unchanged';
    }
    set_modified($file);
}

# tidy all the perl as per .perltidy

my $critic = Perl::Critic->new(-profile => $RealBin . '/.perlcriticrc');
find(
    sub {
        # look for files in . and under lib/
        my $file = $File::Find::name;
        return unless -f $file && -s $file;
        my $rel_file = substr($file, length($RealBin) + 1);
        return if $rel_file =~ m{/} && $rel_file !~ m{^lib/};
        return if basename($rel_file) =~ /^\./ || $rel_file =~ /\.(bak|swp)$/;

        # detect perl by file extension or #!
        my $is_perl = 0;
        if ($file =~ /\.p[ml]$/) {
            $is_perl = 1;
        } else {
            open(my $fh, '<', $file) or die "open $file $!\n";
            my ($first_line) = <$fh>;
            close($fh) or die $!;
            $is_perl = $first_line =~ m{\#!/usr/bin/perl};
        }
        return unless $is_perl;

        print $rel_file;

        if (!is_modified($file)) {
            say ' unchanged';
            return;
        }

        # init
        my $original = Mojo::File->new($file)->slurp();
        my $input    = $original;
        my $output   = '';

        # sort use lines, as well as their imports
        $input = sort_use($input);

        # apply perltidy
        Perl::Tidy::perltidy(
            source      => \$input,
            destination => \$output,
        );

        # apply changes
        if ($original ne $output) {
            Mojo::File->new($file)->spurt($output);
            say " \e[34mupdated\e[0m";
        } else {
            say ' unchanged';
        }

        # critic
        my @issues = $critic->critique($file);
        foreach my $issue (@issues) {
            (my $policy = $issue->policy) =~ s/^Perl::Critic::Policy:://;
            say "\e[33m", $rel_file, ':', $issue->line_number, ' ', $issue->description, ' (', $policy, ")\e[0m";
        }

        if (@issues) {
            clear_modified($file);
        } else {
            set_modified($file);
        }
    },
    $RealBin
);

sub sort_use {
    my ($input) = @_;
    my @input = split(/\n/, $input);
    my @output;

    # find use blocks, assumes they are always followed by a blank line
    my $in_use_block = 0;
    my @uses;
    foreach my $line (@input) {
        if ($in_use_block) {
            if ($line eq '') {
                $in_use_block = 0;
                push @output, sort_uses(@uses), '';
                @uses = ();
                next;
            }
        }

        if ($line =~ /^use /) {
            $in_use_block = 1;
            push @uses, $line;
            next;
        }

        push @output, $line;
    }
    push @output, sort_uses(@uses) if @uses;

    return join("\n", @output) . "\n";
}

sub sort_uses {
    my @uses = @_;

    # skip setup / lib blocks
    if (any { /^use local::lib/ || /^use lib / || /^use base / } @uses) {
        return @uses;
    }

    # sort imports
    foreach my $line (@uses) {
        next unless $line =~ /^(use\s+\S+)\s+qw\(([^\)]+)\);$/;
        my ($module, $imports) = ($1, $2);
        my @imports = split(' ', $imports);
        $imports = join(' ', sort split(' ', $imports));
        $line = "$module qw( $imports );";
    }

    # sort modules
    @uses = sort { lc($a) cmp lc($b) } @uses;
    return @uses;
}

# lastmod tracking

my $lastmod;

sub _init_modified {
    return if defined $lastmod;

    $lastmod = {};
    if (open(my $fh, '<', "$RealBin/.dev-precommit")) {
        while (<$fh>) {
            next unless /^(.+)\t(\d+)$/;
            $lastmod->{$1} = $2;
        }
        close($fh) || die $!;
    }
}

sub _write_modified {
    open(my $fh, '>', "$RealBin/.dev-precommit") or die $!;
    foreach my $fn (sort keys %{$lastmod}) {
        say {$fh} "$fn\t" . $lastmod->{$fn};
    }
    close($fh) or die $!;
}

sub is_modified {
    my ($file) = @_;
    _init_modified();

    my $mtime    = (stat($file))[9];
    my $abs_file = abs_path($file);
    $lastmod->{$abs_file} //= 0;

    return $lastmod->{$abs_file} != $mtime;
}

sub set_modified {
    my ($file) = @_;
    _init_modified();

    $lastmod->{ abs_path($file) } = (stat($file))[9];
    _write_modified();
}

sub clear_modified {
    my ($file) = @_;
    _init_modified();

    delete $lastmod->{ abs_path($file) };
    _write_modified();
}