mdl-audit

#!/usr/bin/perl

#
# This is sorta like a moodle aware, git blame on roids
# It generates a summary of how a moodle has diverged from core
# and who did it, and under what WR's (if the git comments are mostly sane)
#
# TODO
# remove changes which are only file permissions
#
# TODO
# 

use strict;
use Data::Dumper;
use lib '/home/brendan/scripts/perllib/';
use ColPrintf;
use Term::ANSIColor;

my $version;

if (-e 'version.php'){

    $version = `git log --oneline  version.php | head -n 1`;
    my $commit = substr($version,0,7);
    chomp $version;
    $version =~ /(\S+)$/;
    $version = "v$1";

    my $verify = `git tag --list | grep '$version'`;
    chomp $verify;
    if ($version ne $verify){
        print "WARNING: Can't find a version tag ($version isn't a tag)\n";
        print "For this to work, you'll need the release tags from moodle HQ locally, so\n";
        print "something like 'git remote add moodle git\@github.com:moodle/moodle.git'\n";
        print "and then 'git fetch --tags moodle'\n\n";
        print "or for totara '??'\n";
        print "and then 'git fetch --tags totara'\n\n";
        print "Using '$commit' instead of tag: $version (WARNING this detection isn't perfect)\n";
        $version = $commit;
    } else {

    }


}

print "Auto detected upstream moodle version '$version'\n";

# run this:
my @diff = `git diff $version --name-status`;

# Remove some whitelist of always present Catalyst stuff
my @diff = grep ! /debian/, @diff;
my @diff = grep ! /Makefile/, @diff;
my @diff = grep ! /dhmm_version/, @diff;

# Find all paths with a version, poor mans auto detect of sub systems
my @plugins = grep /\/version.php/, @diff;


for (@plugins){
    s/.\s+(.*)version.php/$1/g;
}

#print @plugins;


my $c = 0;

sub uniq {
    local %_;
    grep {!$_{$_}++} @_;
}

sub details {

    my ($version, $files) = @_;

    #my @commits = `git log --oneline   $version..HEAD  $plugin`;
    #my @commits = `git log --pretty=format:"%an:SEP:%s"  $version..HEAD  $files`;

    # This just grabs ALL commits and filters from there, must more robust if the auto detected
    # last upstream version is wrong (which it often is)

    my @commits;

    if (-d $files){
        @commits = `cd $files; git log --pretty=format:"%an:SEP:%s"`;
    } else {
        @commits = `git log --pretty=format:"%an:SEP:%s"   $files`;
    }

    # Remove commits which are from moodle tracker
    @commits = grep ! /MDL-/, @commits;
    @commits = grep ! /MLD-/, @commits;
    @commits = grep ! /DML-/, @commits;
    @commits = grep ! /BETA-/, @commits;
    @commits = grep ! /MNET-/, @commits;
    @commits = grep ! /CONTRIB-/, @commits;
    @commits = grep ! /MDLSITE-/, @commits;

    # Remove commits which are just an upstream merge
    @commits = grep ! /Merge.*MOODLE_/, @commits;

#    print join '', @commits;

    my @issues;
    my @who; # = @commits;

    foreach my $com (@commits){

        my @match = $com =~ m/(([A-Z]+-|WR#)\d+)/g;

        # above matches twice, lets only extra the full match
        for(my $c=0; $c <= $#match; $c +=2){
            push @issues, $match[$c];
            push @who, $com;
        }
# print "ADD $com";
    }
#    print "WHO0: --\n";
#    print join '--',@who;


    # Sort the issues by alpha by tracker and then numerical by issue num
    @issues = sort {
        $a =~ /(\D+)(\d+)/;
        my $a1 = $1;
        my $a2 = $2;
        $b =~ /(\D+)(\d+)/;
        my $b1 = $1;
        my $b2 = $2;
        return ($a1 cmp $b1) || ($a2 <=> $b2);
    } @issues;
    @issues = uniq @issues;

    # if we have multiple trackers, let's remove the prefix to save space
    # eg LT-101,LT-102 becomes LT-101,102

    my $wrs;
    my $last = '';
    for(my $c=0; $c<=$#issues; $c++){
        my $tok = $issues[$c];
        $tok =~ /^(\D*)\-?(\d+)$/;
        if ($c ne 0){ $wrs .= ' '; }
        if ($1 ne $last){ $wrs .= $1;  }
        $wrs .= $2;
        $last = $1;
    }

#    print "WHO1: --\n";
#    print join '--',@who;

    for (@who){
        s/^(.*):SEP.*$/$1/g;
        chomp;
    }
#    print "WHO2: --\n";
#    print join '--',@who;

    @who = sort @who;
    @who = uniq @who;
#    print "WHO3: --\n";
#    print join '--',@who;

    my $who = join ', ', @who;
#    print "WHO $who <<<<<<<\n";

    return $who, $wrs;

}


# show all plugins, which are pure A adds
if (@plugins){
    print '-' x 120;
    print "\nNew plugins added to this moodle:          File changes         Tracker                   Who\n";
    foreach my $plugin (@plugins){

#    if ($c++ > 3){ last; }

        chomp $plugin;

        # Remove plugin related files from the diff
        my @add = grep /A\s+$plugin/, @diff;
        @diff = grep ! /A\s+$plugin/, @diff;
        my $add = $#add>=0 ? "A ".($#add+1): '';

        my @del = grep /D\s+$plugin/, @diff;
        @diff = grep ! /D\s+$plugin/, @diff;
        my $del = $#del>=0 ? "D ".($#del+1): '';

        my @mod = grep /M\s+$plugin/, @diff;
        @diff = grep ! /M\s+$plugin/, @diff;
        my $mod = $#mod>=0 ? "M ".($#mod+1) : '';

        my ($who, $wrs) = details($version, $plugin);


        col_printf "%-2s%-40s %-6s %-6s %-6s %-25s %-35s\n", 'A', $plugin, $add, $mod, $del, $wrs, $who;
    }

}

# exit;


# Everything below here is just showing extra files which haven't been
# detected as part of a moodle plugin ie they do not have a parent dir
# which contains a version.php file - which is generally a coding failure

my @added = grep /A\s/, @diff;
my @diff = grep ! /A\s/, @diff;


if (@added){
    print '-' x 80;
    print "\nThese are other new files added to moodle: (probably missing a proper version.php file)\n";
    foreach my $line ( @added ){

        chomp $line;
        $line =~ /.\s+(\S.*)$/;
        my $file = $1;
        my ($who, $wrs) = details($version, $file);
        col_printf "%-58s %-20s %-30s \n", $file, $wrs, $who;
    }


}
if (@diff){
    my $REVERSE = color('reverse');
    my $RESET = color('reset');
    print '-' x 80;
    print "\n$REVERSE WARNING $RESET These are changes to core moodle\n";
    foreach my $line ( @diff ){

        chomp $line;
#print "==$line==\n";
        $line =~ /.\s+(\S.*)$/;
        my $file = $1;
        my ($who, $wrs) = details($version, $file);

        col_printf "%-58s %-20s %-30s \n", $file, $wrs, $who;
    }
}


# find anything which is M and highlight it

print "\nTo drill in further:\n\$ git diff $version --name-status [path]\n";