use strict;
use warnings;

use Test::More import => ['!pass'];

unless ( $ENV{RELEASE_TESTING} ) {
    plan( skip_all => "Author tests not required for installation" );
}

#### Change these values if the Changelog syntax changes :

# changelog file name
my $changelog_filename = 'CHANGES';

# don't check for versions older or equal to this
my $stop_checking_version = '1.3079_03';

# ordered list of possible sections
my @possible_sections = ('SECURITY', 'API CHANGES', 'BUG FIXES', 'ENHANCEMENTS', 'DOCUMENTATION', );

#################


# beware : below are some crazy paranoid testing

my $possible_sections = join('|', @possible_sections);

open(my $fh, '<', $changelog_filename);
my @lines = map { chomp; $_ } <$fh>;

my $tests_count = 0;
while (1) { $lines[$tests_count++] !~ /^\Q$stop_checking_version\E(?:\s|$)/ or last }

# test count = number of lines + 1
plan tests => $tests_count;

my @struct;

{ # start scoping

my $line_nb = 0;
my $line;
sub _consume_line { $line = shift @lines;
                    defined $line or goto END_CHANGES;
                    $line =~ /^\Q$stop_checking_version\E(?:\s|$)/ and goto END_CHANGES;
                    $line_nb++;
                  }
sub _peek_line { $line = $lines[0];
                 defined $line or goto END_CHANGES;
                 $line =~ /^\Q$stop_checking_version\E(?:\s|$)/ and goto END_CHANGES;
               }
sub _fail { fail("changelog error (line $line_nb): " . shift() . " line was : '$line'"); }
sub _fail_bail_out { _fail(@_); BAIL_OUT("changelog is not safe enough to continue checking"); }
sub _pass { Test::More::pass("check line $line_nb"); }

my $current_version;
my $current_version_is_dev;
my $current_section;
my $current_item_start;
my $current_item;

WHERE_NEXT:
_peek_line();
if (defined $current_item || defined $current_item_start) {
    # we can have an item line, a new item start, or a separator
    $line =~ /^\s+\*/  and goto ITEM_START;
    $line =~ /^\s+\S+/ and goto ITEM;
    $line =~ /^\s*$/   and goto SEPARATOR;
    _fail_bail_out("next line doesn't look like an item line, a new item start, or a separator");
}
if (defined $current_section) {
    # we can have an item line, a new item start
    $line =~ /^\s+\*/  and goto ITEM_START;
    $line =~ /^\s+\S+/ and goto ITEM;
    _fail_bail_out("next line doesn't look like an item line, a new item start");
}
if (defined $current_version) {
    # we can have a new section or a new version
    $line =~ /^\s/   and goto SECTION;
    $line =~ /^\S/   and goto VERSION;
    _fail_bail_out("next line doesn't look like a new section or new version");
}
goto VERSION;


SEPARATOR:
# separator
_consume_line();
$line eq '' ? _pass() : _fail_bail_out("should be a separator (empty line)");
$current_section = undef;
$current_item_start = undef;
$current_item = undef;
goto WHERE_NEXT;

VERSION:
# version number
_consume_line();
if ( (my ($pre, $version, $post)) = ($line =~ /^(\s*)(\S.*\S)(\s*)$/)) {
    defined $pre or $pre = '';
    defined $post or $post = '';
    my $lpre = length $pre;
    my $lpost = length $post;
    $lpre and _fail("line starts with $lpre blank caracters, but it should not");
    $lpost and _fail("line ends with $lpre blank caracters, but it should not");
    like($version, qr/^{{\$NEXT}}$|^\d\.\d{4}(_\d{2}   |      )\d{2}.\d{2}.\d{4}$/, "changelog line $line_nb: check version failed");
    $version =~ qr/^({{\$NEXT}})$|^\d\.\d{4}(_\d{2}   |      )\d{2}.\d{2}.\d{4}$/;
#    print STDERR " ------->  [$1] [$2]\n";
    $current_version_is_dev = defined $1 || $2 =~ /^_\d{2}/;

    $current_version = [];
    $current_section = undef;
    $current_item_start = undef;
    $current_item = undef;
    push @struct, { $version => $current_version };
} else {
    _fail("line should contain a version number, but it contains '$line'.");
}
$current_version_is_dev
  and goto SEPARATOR;
goto CODENAME;

CODENAME:
# the codename is not mandatory, but strongly encouraged. So warn if it's not
# there, but don't die
_peek_line();
if ($line =~ /^\s*$/) {
    warn "It's recommended to add a CodeName to stable releases (non-dev versions).\n"
         . "There is no CodeName at line $line_nb. Codename format is : "
         . "    ** Codename: <The Name> // <The person it's dedicated to> ** \n"
         . "The // ... part is optional.";
    goto SEPARATOR;
}
_consume_line();
like($line, qr|^    \*\* Codename: [^/]+( // [^/]+)? \*\*$|);
goto SEPARATOR;

SECTION:
_consume_line();
if ( (my ($pre, $section, $post)) = ($line =~ /^(\s*)(\S.*\S)(\s*)$/) ) {
    defined $pre or $pre = '';
    defined $post or $post = '';
    my $lpre = length $pre;
    my $lpost = length $post;
    $pre ne '    ' and _fail("line starts with $lpre blank caracters, but it should start with exactly 4 spaces");
    $lpost and _fail("line ends with $lpre blank caracters, but it should not");
    like($section, qr/^\[ ($possible_sections) \]$/, "line $line_nb: check section");
    $current_section = [];
    $current_item_start = undef;
    $current_item = undef;
    push @$current_version, { $section => $current_section };
} else {
    _fail_bail_out("line should contain a section string, but it contains '$line'.");
}
goto WHERE_NEXT;

ITEM_START:
_consume_line();
if ( (my ($pre, $item_start)) = ($line =~ /^(\s*)(.+)$/) ) {
    defined $pre or $pre = '';
    my $lpre = length $pre;
    $pre ne '    ' and _fail("line starts with $lpre blank caracters, but it should start with exactly 4 spaces");
    like($item_start, qr/^\* /, "line $line_nb: item line starts with *");
    $current_item_start = [ $item_start ];
    $current_item = undef;
    push @$current_section, $current_item_start;
} else {
    _fail_bail_out("line should contain an item start, but it contains '$line'.");
}
goto WHERE_NEXT;

ITEM:
_consume_line();
if ( (my ($pre, $item)) = ($line =~ /^(\s*)(.+)$/) ) {
    defined $pre or $pre = '';
    my $lpre = length $pre;
    $pre ne '      ' and _fail("line starts with $lpre blank caracters, but it should start with exactly 6 spaces");
    _pass();
    $current_item = $item;
    push @$current_item_start, $item;
} else {
    _fail_bail_out("line should contain an item, but it contains '$line'.");
}
goto WHERE_NEXT;

END_CHANGES:

} # end scoping


# we are doing advanced testing in a subtest because we couldn't compute the
# number of test upfront. But now we can

subtest 'Advanced testing of changelog' => sub {

    my $sections_count = 0;

    my $versions_next_count = 0;
    my $versions_count = scalar(@struct);
    foreach my $version_struct (@struct) {
        my $version_number = (keys(%$version_struct))[0];
        $version_number eq '{{$NEXT}}'
          and $versions_next_count++;
        $sections_count += scalar(@{$version_struct->{$version_number}});
    }

    my $section_comparison_count = ( ($versions_count-1) + ( ($versions_count-1) - $versions_next_count ) * 2);
    $section_comparison_count >= 0
      or $section_comparison_count = 0;

    plan tests => $section_comparison_count + $sections_count;

    my $previous_version_struct;
    foreach my $version_struct (reverse @struct) {
        my $version_number = (keys(%$version_struct))[0];
        my $previous_version_number = (keys(%$previous_version_struct))[0];
        if (defined $previous_version_number) {
            isnt ($previous_version_number, '{{$NEXT}}', "version $version_number has {{\$NEXT}} as previous version, that's wrong");
            if ($version_number ne '{{$NEXT}}') {
                my ($v1,  $v2,  $v3,  $d1,  $d2,   $d3) = ( $version_number          =~ /^(\d)\.(\d{4})(?:_(\d{2}))?\s+(\d{2})\.(\d{2})\.(\d{4})$/ );
                my ($pv1, $pv2, $pv3, $pd1, $pd2, $pd3) = ( $previous_version_number =~ /^(\d)\.(\d{4})(?:_(\d{2}))?\s+(\d{2})\.(\d{2})\.(\d{4})$/ );
                ok($v1 >= $pv1 || $v2 >= $pv2 || ($v3||0) >= ($pv3||0), "version '$version_number' is not greater than '$previous_version_number', that's wrong");
                ok($d3 >= $pd3 || $d2 >= $pd2 ||      $d1 >= $pd1,      "version '$version_number' is not newer (date) than '$previous_version_number', that's wrong");
            }
        }
        my $previous_section_name;
        foreach my $section_struct (@{$version_struct->{$version_number}}) {
            my $section_name = (keys(%$section_struct))[0];
            if (defined $previous_section_name) {
                my @temp = @possible_sections;
                while (1) {
                    my $s = shift @temp;
                    $previous_section_name eq "[ $s ]"
                      and last;
                }
                my $allowed_section_names = join('|', @temp);
                like($section_name, qr/^\[ ($allowed_section_names) \]$/, "failure : section '$section_name' cannot come after '$previous_section_name'.");
            } else {
                Test::More::pass('first section ok');
            }
            $previous_section_name = $section_name;
        }
        $previous_version_struct = $version_struct;
    }
};