File Coverage

blib/lib/Test/Changes/Strict/Simple.pm

Criterion	Covered	Total	%
statement	214	219	97.7
branch	125	138	90.5
condition	40	50	80.0
subroutine	21	21	100.0
pod	1	1	100.0
total	401	429	93.4

package Test::Changes::Strict::Simple;

use 5.010;
use strict;
use warnings;
use parent 'Exporter';
our @EXPORT = qw(changes_strict_ok);

use version;

use Test::Builder;

use Time::Local;
use Carp;
use POSIX qw(strftime);

our $VERSION = '0.06';

#
# The use of global variables is acceptable, as we never check more than one
# Changes file at a time.
#
my $TB = Test::Builder->new;

my $Ver_Re = qr/\d+\.\d+/;

use constant {
              NOW => time,
              map { $_ => $_ } qw(
                                   st_chlog_head
                                   st_empty_after_head
                                   st_version
                                   st_empty_after_version
                                   st_item
                                   st_item_cont
                                   st_empty_after_item
                                   st_EOF
                                )
             };


my $Test_Name = "Changes file passed strict checks";
my $Empty_Line_After_Version;
my $Chk_Dots = 1;
my $Reverse;

sub import {
  my $class = shift;

  my %opts;                     # Option key/value pairs.
  my @exports;                  # Requested symbols to export.

  # Separate options (starting with '-') from export symbols.
  while (@_) {
    if (@_ >= 2 && $_[0] =~ /^-/) {
      my ($key, $val) = splice(@_, 0, 2);
      $key =~ s/^-//;           # Remove leading dash.
      $opts{$key} = $val;
    } else {
      push(@exports, shift);
    }
  }

  # Process known options.
  my $no_export = delete $opts{no_export};
  $Empty_Line_After_Version = delete $opts{empty_line_after_version};
  if (exists($opts{version_re})) {
    $Ver_Re = delete $opts{version_re};
    croak("-version_re: option has an invalid value") if ref($Ver_Re) ne "Regexp";
  }
  $Chk_Dots = delete $opts{check_dots} if exists($opts{check_dots});
  $Reverse = delete $opts{reverse_version_order};

  # Fail on unknown options.
  croak("Unknown option(s): " . join(", ", keys %opts)) if %opts;

  # Export logic.

  if (@exports) {
    # Explicit symbol list provided ==> export exactly those.
    __PACKAGE__->export_to_level(1, $class, @exports);
  } elsif ($no_export) {
    # -no_export requested ==> export nothing.
    return;
  } else {
    # No arguments ==> preserve standard Exporter behaviour.
    # This keeps the distinction between:
    #   use Test::Changes::Strict::Simple;
    #   use Test::Changes::Strict::Simple ();
    __PACKAGE__->export_to_level(1, $class, @EXPORT);
  }
}


# ------------------

sub changes_strict_ok {
  my %args = @_;
  my $changes_file  = delete($args{changes_file}) // "Changes";
  my $release_today = delete($args{release_today});
  my $mod_version;
  if (exists($args{module_version})) {
    $mod_version = delete($args{module_version}) // croak("module_version is undef");
  }
  croak("Unknown arguments(s): " . join(", ", keys %args)) if %args;

  my $test_name = "Changes file passed strict checks";

  my @lines;
  _read_file($changes_file, \@lines) or return;

  _check_and_clean_spaces(\@lines) or return;

  my $trailing_empty_lines = _trim_trailing_empty_lines(\@lines);
  _check_title(\@lines) or return;

  my @versions;
  _check_changes(\@lines, \@versions) or return;
  @versions = reverse(@versions) if $Reverse;
  _check_version_monotonic(\@versions) or return;
  if ($mod_version) {
    my $top_ver = $versions[0]->{version_str};
    $mod_version eq $top_ver or
      return _not_ok("Highest version in changelog is $top_ver, not $mod_version as expected");
  }
  if ($release_today) {
    my $top_date = $versions[0]->{date};
    $top_date eq strftime('%Y-%m-%d', localtime) or
      return _not_ok("The date of the latest version is not today");
  }

  my $ok = $TB->ok($trailing_empty_lines <= 3, $Test_Name) or
    $TB->diag("more than 3 empty lines at end of file");
  return $ok;
}


sub _read_file {
  my ($fname, $lines) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  -e $fname or return _not_ok("The '$fname' file does not exist");
  -f $fname && -r $fname && -T $fname or
    return _not_ok("The '$fname' file is not a readable text file");
  open(my $fh, '<', $fname) or return _not_ok("Cannot open '$fname': $!");
  @$lines = <$fh> or return _not_ok("The '$fname' file empty");
  substr($lines->[-1], -1) eq "\n" or return _not_ok("'$fname': no newline at end of file");
  chomp(@$lines);
  return !0;
}


sub _trim_trailing_empty_lines {
  my ($aref) = @_;
  my $removed = 0;

  while (@$aref && $aref->[-1] eq '') {
    pop(@$aref);
    $removed++;
  }
  push(@$aref, q{});            # We need exactly 1 trailing empty line.
  return $removed;
}


sub _check_and_clean_spaces {
  my ($lines) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  my (@other_spaces, @trailing_spaces);
  for (my $i = 1; $i <= @$lines; ++$i) {
    $lines->[$i - 1] =~ s/[^\S\ ]/\ /g and push(@other_spaces, $i);
    $lines->[$i - 1] =~ s/\s+$// and push(@trailing_spaces, $i);
  }
  my $diag;
  if (@other_spaces) {
    my $plural = @other_spaces > 1 ? "s" : "";
    $diag = "Non-space white character found at line$plural " . join(', ', @other_spaces);
  }
  if (@trailing_spaces) {
    my $plural = @trailing_spaces > 1 ? "s" : "";
    $diag = join('. ',
                 ($diag // ()),
                 "Trailing white character at line$plural " . join(', ', @trailing_spaces));
  }
  return $diag ? _not_ok($diag) : !0;
}


sub _check_title {
  my ($lines) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  my $test_name = "Header line ok";
  my $ok = $lines->[0] =~ qr/
                              ^
                              Revision\ history\ for\ (?:
                                (?:perl\ )?
                                (?:
                                  (?:module\ \w+(?:::\w+)*)
                                |
                                  (?:distribution\ \w+(?:-\w+)*)
                                )
                              )
                              $
                            /x;
  return $ok ? !0 : _not_ok("Missing or malformed 'Revision history ...' at line 1");
}


sub _check_changes {
  my ($lines, $versions) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  my %states = (
                +st_chlog_head          => [st_empty_after_head],
                +st_empty_after_head    => [st_version],
                $Empty_Line_After_Version ? (
                                             +st_version             => [st_empty_after_version],
                                             +st_empty_after_version => [st_item],
                                            )
                                          : (
                                             +st_version             => [st_item],
                                            ),
                +st_item                => [st_item, st_item_cont, st_empty_after_item, st_EOF],
                +st_item_cont           => [st_item, st_item_cont, st_empty_after_item],
                +st_empty_after_item    => [st_version, st_EOF],
                +st_EOF                 => [],
               );
  $_ = { map { $_ => undef } @$_ } for values %states;
  my %empty_line_st = (+st_chlog_head => st_empty_after_head,
                       +st_item       => st_empty_after_item,
                       $Empty_Line_After_Version ? (+st_version => st_empty_after_version) : (),
                      );
  my %item_line = (+st_item => undef, +st_item_cont => undef);
  my $indent;
  my $state = st_chlog_head;
  my %errors;
  my $err = sub { push(@{$errors{$_[0]}}, $_[1]); };
  my $i = 2;
  for (; $i <= @$lines; ++$i) {
    my $line = $lines->[$i - 1];
    if ($line eq "") {
      my $old_state = $state;
      $err->($i - 1, "missing dot at end of line")
        if $Chk_Dots && (exists($item_line{$old_state}) && $lines->[$i - 2] !~ /\.$/);


      if (exists($item_line{$old_state}) || $old_state eq st_empty_after_item) {
        my $next_line = $lines->[$i];
        if (defined($next_line) && $next_line !~ /^\S/) {
          $err->($i, "unexpected empty line");
          last;
        }
        $state = st_empty_after_item;
      } else {
        $state = $empty_line_st{$old_state} or do { $err->($i, "unexpected empty line");
                                                    last;
                                                  };
      }
    } elsif ($line =~ /^[^-\s]/) {
      exists($states{$state}->{+st_version}) or do { $err->($i, "unexpected version line");
                                                     last;
                                                   };
      $state = st_version;
      my $result = _version_line_check($line);
      if (ref($result)) {
        $result->{line} = $i;
        push(@$versions, $result);
      } else {
        $err->($i, "version check: $result");
        last;
      }
    } elsif ($line =~ s/^(\s*)-//) {
      my $heading_spaces = $1;
      exists($states{$state}->{+st_item}) or do { $err->($i, "unexpected item line");
                                                  last;
                                                };
      $err->($i - 1, "missing dot at end of line")
        if $Chk_Dots && (exists($item_line{$state}) && $lines->[$i - 2] !~ /\.$/);
      $line =~ /^ \S+/ or do { $err->($i, "invalid item content");
                               last;
                             };
      $state = st_item;
      if ($heading_spaces eq "") {
        $err->($i, "no indentation");
      } elsif (defined($indent)) {
        $err->($i, "wrong indentation") if length($heading_spaces) != $indent;
      } else {
        $indent = length($heading_spaces);
      }
    } elsif ($line =~ /^(\s+)[^-\s]/) {
      exists($states{$state}->{+st_item_cont}) or do { $err->($i, "unexpected item continuation");
                                                       last;
                                                     };
      my $state = st_item_cont;
      my $heading_spaces = $1;
      length($heading_spaces) == $indent + 2 or do { $err->($i, "wrong indentation"); };
    }
  }
  my $diag;
  if (%errors || ($i > @$lines && !exists($states{$state}->{+st_EOF}))) {
    if (%errors) {
      $diag = join("\n",
                   (map {"Line $_: " . join("; ", @{$errors{$_}})}
                    (sort { $a <=> $b } keys(%errors))));
    }
    $diag = join("\n", ($diag // ()), "Unexpected end of file")
      if ($i > @$lines && !exists($states{$state}->{+st_EOF}));
  }
  return $diag ? _not_ok($diag) : !0;
}


sub _check_version_monotonic {
  my ($versions) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  my $diag;
  if (@$versions) {
    for (my $i = 0; $i < $#$versions; ++$i) {
      my ($v1, $e1) = @{$versions->[$i]    }{qw(version epoch)};
      my ($v2, $e2) = @{$versions->[$i + 1]}{qw(version epoch)};
      unless ($v1 > $v2) {
        my $vs1 = $versions->[$i]->{version_str};
        my $vs2 = $versions->[$i + 1]->{version_str};
        $diag = $v1 == $v2 ? "$vs1: duplicate version" : "$vs1 vs. $vs2: wrong order of versions";
        last;
      }
      if ($e1 < $e2) {
        my $d1 = $versions->[$i]->{date};
        my $d2 = $versions->[$i + 1]->{date};
        $diag = "date $d1 < $d2: chronologically inconsistent";
        last;
      }
    }
  } else {
    $diag = "No versions to check";
  }
  return $diag ? _not_ok($diag) : !0;
}


# ---------------------------- Helper functions ---------------------------------------

sub _version_line_check {
  # Line is already trimmed!
  my $line = shift;
  (my ($ver_str, $date) = split(/\s+/, $line)) == 2 or return("not exactly two values");
  $ver_str =~ /^$Ver_Re$/ or return "$ver_str: invalid version";
  my $version;
  eval { $version = version->parse($ver_str); 1; } or return("$ver_str: invalid version");
  $date =~ /^(\d{4})-(\d{2})-(\d{2})$/ or return("$date: invalid date: wrong format");
  my ($y, $m, $d) = ($1, $2, $3);
  my $epoch;
  eval {
    $epoch = Time::Local::timelocal(0, 0, 0, $d, $m - 1, $y);
    1;
  } or return "'$date': invalid date";
  $y     >= 1987 or return "$date: before Perl era";
  $epoch <= NOW  or return "$date: date is in the future.";
  return { version     => $version,
           version_str => $ver_str,
           date        => $date,
           epoch       => $epoch};
}


#---------------------------------------------------------

sub _not_ok {
  my ($diag) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  $TB->ok(0, $Test_Name);
  $TB->diag($diag);
  return !1;
}


1; # End of Test::Changes::Strict::Simple



__END__