# -*- perl -*-
# warnings-transitions.pl
# Adapted from Devel::Git::MultiBisect's xt/104-gcc-build-transitions-warnings.t
use 5.14.0;
use warnings;
use Devel::Git::MultiBisect::Opts qw( process_options );
use Devel::Git::MultiBisect::BuildTransitions;
use Test::More;
use Carp;
use File::Spec;
use Data::Dump qw(dd pp);
use Tie::File;
use Getopt::Long;

=encoding utf8
=head1 NAME

warnings-transitions.pl

=head1 ABSTRACT

Identify Perl 5 commit at which a given build-time warning first appeared

=head1 SYNOPSIS

    perl warnings-transitions.pl \
        --git_checkout_dir="$GIT_WORKDIR/perl2" \
        --workdir="$HOMEDIR/learn/perl/multisect/testing/gcc" \
        --first=d7fb2be259ba2ec08e8fa0e88ad0ee860d59dab9 \
        --last=043ae7481cd3d05b453e0830b34573b7eef2aade \
        --pattern_sought="Opcode.xs:_:_: warning: overflow in implicit constant conversion [Woverflow]"

=head1 DESCRIPTION

This program uses methods from L<Devel::Git::MultiBisect::BuildTransitions> to
identify the commit in Perl 5 blead where a specified build-time warning first
appeared.

=head1 USAGE

Call this program with command-line switches.  At the present time there are 4
command-line switches whose values the user must provide, as there are no
defaults.  There is 1 command-line switch which is recommended and for which a
value must be provided.  There are currently 4 other command-line switches for
which defaults are provided.  All switches are called in "long option" style,
I<i.e.> starting with two hyphens (C<-->).

=head2 Required Command-Line Switches

=over 4

=item * C<--git_checkout_dir>

Full path to a directory holding a F<git> checkout of the Perl 5 core
distribution.

=item * C<--workdir>

Full path to a directory where files created in the course of running the
program will be deposited.

=item * C<--first>

Full (40 character) SHA of the first (chronologically earliest) F<git> commit
to the Perl 5 repository to be tested during bisection.

=item * C<--last>

Full (40 character) SHA of the last (chronologically latest) F<git> commit to
the Perl 5 repository to be tested during bisection.

=back

=head2 Recommended Command-Line Switch

=over 4

=item * C<--pattern_sought>

String holding the build-time (F<make>) warning whose first appearance you are trying to ascertain,
subject to these modifications:

=item *

Substitute one underscore character (C<_>) for the line number
(vertical) and character number (horizontal).

=item *

Remove the hyphen (C<->) between the open bracket (C<\[>) and the upper-case
'W' (C<W>) in the warnings category.

=back

Hence, a warning which appears in captured F<make> output like this:

    Opcode.xs: In function ‘XS_Opcode_invert_opset’:
    Opcode.xs:363:25: warning: overflow in implicit constant conversion [-Woverflow]
      bitmap[opset_len-1] &= ~(0xFF << (PL_maxo & 0x07));
                             ^

... will be called on the command-line like this:

    --pattern_sought="Opcode.xs:_:_: warning: overflow in implicit constant conversion [Woverflow]"

If this switch is called, a value must be provided.  But if the switch is not
called, the program will simply avoid running the code which uses the value.

Note:  If the pattern contains any single-quote mark (C<'>) or similar
characters, you are probably better off double-quoting the pattern on the
command line (as above).

=head2 Optional Command-Line Switches

=over 4

=item * C<compiler>

Compiler (and possibly compiler version) which is generating the warning.
The warning pattern is currently observed in various versions of F<gcc>,
F<g++> and F<clang>.  Defaults to C<gcc>.  Note that if your default version
of F<gcc> is C<7> but you wish to track a warning generated by a different
version of F<gcc>, you would call something like C<gcc-8> (on Linux) or
C<gcc8> on FreeBSD.

    --compiler='gcc-8'

Needless to say, you must have these alternate compiler versions installed.

=item * C<branch>

Branch of the Perl 5 core distribution you are testing for the warning.
Defaults to C<blead>.

    --branch=blead

=item * C<configure_command>

String holding the invocation of F<./Configure> used in builds where the warning's first appearance is being explored.  Defaults to:

    --configure_command='sh ./Configure -des -Dusedevel -Dcc=gcc 1>/dev/null 2>&1'

=item * C<make_command>

String holding the invocation of F<make> used in the builds under investigation.  Defaults to:

    --make_command='make -j${TEST_JOBS} 1>/dev/null'

=back

=head1 PREREQUISITES

Once you have installed the Devel-Git-MultiBisect distribution from CPAN, the
only non-core distribution you need is Data-Dump.

=head1 OUTPUTS

Like all programs using L<Devel::Git::MultiBisect::BuildTransistions>, the
program prints a log to STDOUT of each commit tested.  In the course of
testing a given commit, a file is created in the C<workdir> directory which logs the build-time warnings observed.  Example:

    $ 02b85d3.make.warnings.rpt.txt
    Opcode.xs:_:_: warning: overflow in implicit constant conversion [Woverflow]

When all older-to-newer transitions have been identified, the program creates one additional file in the C<workdir> directory.  This file is named using the compiler used, I<e.g.,> F<transistions.gcc.pl> and looks like this:

    $ cat transitions.gcc.pl
    {
      newest => {
        file => "/home/username/testing/gcc/043ae74.make.warnings.rpt.txt",
        idx => 7,
        md5_hex => "157705edf5caf23f889135270fe56ef7",
      },
      oldest => {
        file => "/home/username/testing/gcc/d7fb2be.make.warnings.rpt.txt",
        idx => 0,
        md5_hex => "19ae20b703848111b41f08bdbc0b2eb7",
      },
      transitions => [
        {
          newer => {
                     file => "/home/username/testing/gcc/aa4119b.make.warnings.rpt.txt",
                     idx => 1,
                     md5_hex => "d41d8cd98f00b204e9800998ecf8427e",
                   },
          older => {
                     file => "/home/username/testing/gcc/d7fb2be.make.warnings.rpt.txt",
                     idx => 0,
                     md5_hex => "19ae20b703848111b41f08bdbc0b2eb7",
                   },
        },
        {
          newer => {
                     file => "/home/username/testing/gcc/02b85d3.make.warnings.rpt.txt",
                     idx => 2,
                     md5_hex => "157705edf5caf23f889135270fe56ef7",
                   },
          older => {
                     file => "/home/username/testing/gcc/aa4119b.make.warnings.rpt.txt",
                     idx => 1,
                     md5_hex => "d41d8cd98f00b204e9800998ecf8427e",
                   },
        },
      ],
    }

The elements in the C<transitions> array above are the points where the
build-time warnings changed.  The user should then manually inspect those
elements to determine where the warning under investigation first appeared.
In addition, if a value is provided for C<--pattern_sought>, then the SHA of
the commit is printed to STDOUT.  However, this functionality should be
considered experimental and YMMV.  See the discussion of that command-line
switch above.

=head1 AUTHOR

Copyright 2020 James E Keenan (JKEENAN).  Last revised March 31 2020.
License:  same terms as Devel::Git::MultiBisect.

=cut

my ($compiler, $pattern_sought, $git_checkout_dir, $workdir, $first, $last, $branch, $configure_command,
$make_command);

GetOptions(
    "compiler=s"            => \$compiler,
    "git_checkout_dir=s"    => \$git_checkout_dir,
    "workdir=s"             => \$workdir,
    "first=s"               => \$first,
    "last=s"                => \$last,
    "branch=s"              => \$branch,
    "configure_command=s"   => \$configure_command,
    "make_command=s"        => \$make_command,
    "pattern_sought=s"      => \$pattern_sought,
) or croak("Error in command-line arguments\n");

my ($quoted_pattern, %args, $params, $self);

# Argument validation

$compiler //= 'gcc';
unless (defined $git_checkout_dir) {
    croak "Must provide value for '--git_checkout_dir' on command-line";
    unless (-d $git_checkout_dir) {
        croak "git_checkout_dir $git_checkout_dir not found";
    }
}
unless (defined $workdir) {
    croak "Must provide value for '--workdir' on command-line";
    unless (-d $workdir) {
        croak "workdir $workdir not found";
    }
}
unless (defined $workdir and -d $workdir) {
    croak "work directory $workdir not defined or not found";
}
for my $p ($first, $last) {
    croak "First and last commits (40-character SHA) must be provided on command-line"
        unless (length($p) == 40);
}
$branch //= 'blead';
$configure_command //=  q|sh ./Configure -des -Dusedevel|
                     . qq| -Dcc=$compiler|
                     .  q| 1>/dev/null 2>&1|;
$make_command //= qq|make -j$ENV{TEST_JOBS} 1>/dev/null|;
if (defined $pattern_sought) {
    croak "pattern_sought, if provided, must be of non-zero length"
        unless length($pattern_sought);
    $quoted_pattern = qr/\Q$pattern_sought\E/;
}

# Prepare for Devel::Git::MultiBisect::Opts::process_options,
# then validate

%args = (
    gitdir              => $git_checkout_dir,
    workdir             => $workdir,
    first               => $first,
    last                => $last,
    branch              => $branch,
    configure_command   => $configure_command,
    make_command        => $make_command,
    verbose             => 1,
);
say '\%args';
pp(\%args);
$params = process_options(%args);
say '$params';
pp($params);

is($params->{gitdir}, $git_checkout_dir, "Got expected gitdir");
is($params->{workdir}, $workdir, "Got expected workdir");
is($params->{first}, $first, "Got expected first commit to be studied");
is($params->{last}, $last, "Got expected last commit to be studied");
is($params->{branch}, $branch, "Got expected branch");
is($params->{configure_command}, $configure_command, "Got expected configure_command");
ok($params->{verbose}, "verbose requested");

# Construct Devel::Git::MultiBisect::BuildTransitions object,
# then validate

$self = Devel::Git::MultiBisect::BuildTransitions->new($params);
ok($self, "new() returned true value");
isa_ok($self, 'Devel::Git::MultiBisect::BuildTransitions');
isa_ok($self, 'Devel::Git::MultiBisect');

pp($self);
ok(! exists $self->{targets},
    "BuildTransitions has no need of 'targets' attribute");
ok(! exists $self->{test_command},
    "BuildTransitions has no need of 'test_command' attribute");

# Validate commit range

my $this_commit_range = $self->get_commits_range();
ok($this_commit_range, "get_commits_range() returned true value");
is(ref($this_commit_range), 'ARRAY', "get_commits_range() returned array ref");
is($this_commit_range->[0], $first, "Got expected first commit in range");
is($this_commit_range->[-1], $last, "Got expected last commit in range");
say scalar @{$this_commit_range}, " commits found in range";

# Bisect!

my $rv = $self->multisect_builds( { probe => 'warning' } );
ok($rv, "multisect_builds() returned true value");

note("get_multisected_outputs()");

my $multisected_outputs = $self->get_multisected_outputs();
pp($multisected_outputs);

is(ref($multisected_outputs), 'ARRAY',
    "get_multisected_outputs() returned array reference");
is(scalar(@{$multisected_outputs}), scalar(@{$self->{commits}}),
    "get_multisected_outputs() has one element for each commit");

note("inspect_transitions()");

my $transitions = $self->inspect_transitions();

my $transitions_report = File::Spec->catfile($workdir, "transitions.$compiler.pl");
open my $TR, '>', $transitions_report
    or croak "Unable to open $transitions_report for writing";
my $old_fh = select($TR);
dd($transitions);
select($old_fh);
close $TR or croak "Unable to close $transitions_report after writing";

is(ref($transitions), 'HASH',
    "inspect_transitions() returned hash reference");
is(scalar(keys %{$transitions}), 3,
    "inspect_transitions() has 3 elements");
for my $k ( qw| newest oldest | ) {
    is(ref($transitions->{$k}), 'HASH',
        "Got hashref as value for '$k'");
    for my $l ( qw| idx md5_hex file | ) {
        ok(exists $transitions->{$k}->{$l},
            "Got key '$l' for '$k'");
    }
}
is(ref($transitions->{transitions}), 'ARRAY',
    "Got arrayref as value for 'transitions'");
my @arr = @{$transitions->{transitions}};
for my $t (@arr) {
    is(ref($t), 'HASH',
        "Got hashref as value for element in 'transitions' array");
    for my $m ( qw| newer older | ) {
        ok(exists $t->{$m}, "Got key '$m'");
        is(ref($t->{$m}), 'HASH', "Got hashref");
        for my $n ( qw| idx md5_hex file | ) {
            ok(exists $t->{$m}->{$n},
                "Got key '$n'");
        }
    }
}

if (defined $pattern_sought) {
    dd($quoted_pattern);
    my $first_commit_with_warning = '';
    LOOP: for my $t (@arr) {
        my $newer = $t->{newer}->{file};
        say "Examining $newer";
        my @lines;
        tie @lines, 'Tie::File', $newer or croak "Unable to Tie::File to $newer";
        for my $l (@lines) {
            if ($l =~ m/$quoted_pattern/) {
                $first_commit_with_warning =
                    $multisected_outputs->[$t->{newer}->{idx}]->{commit};
                untie @lines;
                last LOOP;
            }
        }
        untie @lines;
    }
    say "Likely commit with first instance of warning is $first_commit_with_warning";
}

say "See results in:\n$transitions_report";
say "\nFinished";

done_testing();

