package Test::Most::Explain;

use strict;
use warnings;

use Test::Builder;
use Scalar::Util qw(blessed reftype);
use Data::Dumper ();

use Exporter 'import';
our @EXPORT_OK = qw(explain);

my $TB = Test::Builder->new;

=head1 NAME

Test::Most::Explain - Enhanced diagnostics for Test::More with structured diffs and helpful hints

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

    use Test::More;
    use Test::Most::Explain qw(explain);

    # Use explain() directly
    my $msg = explain("foo", "fob");
    diag $msg;

    # Or rely on automatic diagnostic enhancement
    is_deeply(
        { a => 1, b => [1,2,3] },
        { a => 1, b => [1,9,3] },
        'deep structure mismatch'
    );

    # On failure, Test::Most::Explain replaces Test::More's
    # default "got/expected" output with a structured diff
    # and helpful hints.

=head1 DESCRIPTION

Test::Most::Explain provides clearer, more actionable diagnostics for
failing tests. It works in two complementary ways:

=head2 Automatic enhancement of Test::More diagnostics

When the module is loaded, it installs a small wrapper around
C<Test::Builder::diag>. This wrapper detects Test::More's standard
failure diagnostics:

    Failed test ...
    #     got: ...
    # expected: ...

Whenever such output is seen, Test::Most::Explain suppresses the
original diagnostics and replaces them with a structured explanation
generated by C<explain()>.

This means existing test code such as:

    is_deeply($got, $exp, 'something');

automatically produces richer diagnostics like:

    Deep structure comparison failed:
      Got:      { ... }
      Expected: { ... }
      Possible causes:
        . Missing key in got: foo
        . Array length differs

Only Test::More-style failure messages are intercepted. All other
C<diag()> calls pass through unchanged.

=head2 Motivation

Perl's default test diagnostics are functional but terse. When complex
structures differ, the default output often shows only memory addresses.
Test::Most::Explain aims to provide clearer diffs, contextual hints, and
more helpful deep-structure reporting without adding heavy dependencies
or requiring changes to existing test code.

=cut

#------------------------------------------------------------
# Install a diag() hook
#------------------------------------------------------------
{
	no warnings 'redefine';
	my $orig = \&Test::Builder::diag;

	*Test::Builder::diag = sub {
		my ($self, @msg) = @_;

		# If this looks like Test::More failure output, suppress it
		if (_looks_like_test_more_failure(@msg)) {
			_emit_explain(@msg);
			return;
		}

		# Otherwise, behave normally
		return $orig->($self, @msg);
	};
}

=head1 METHODS

=head2 explain

Purpose:
  Produce a human-readable explanation of differences between two
  values. Handles scalars, arrays, hashes, blessed references, and
  mixed structures.

Arguments:
  ($got, $exp) - any two Perl values (scalars or references).

Returns:
  A string describing the difference. Never dies.

Side effects:
  None. This routine does not emit diagnostics; it only returns a
  string.

Notes:
  - Undef is normalized to an empty string for scalar comparison.
  - Deep structures are dumped using Data::Dumper.

Example:

    my $msg = explain("foo", "fob");
    diag $msg;

The C<explain()> routine compares two values and returns a human-readable
description of how they differ. It handles:

=over 4

=item * simple scalars

=item * arrays

=item * hashes

=item * blessed references

=item * mixed or unexpected structures

=back

For scalars, C<explain()> reports the first differing character and shows
context around the mismatch. For deep structures, it emits compact dumps
of each side and highlights structural issues such as:

=over 4

=item * differing array lengths

=item * missing or extra hash keys

=item * blessed vs unblessed mismatches

=item * Unicode differences

=item * leading or trailing whitespace

=item * case-only differences

=back

C<explain()> never dies and always returns a string.

=head3 API Specification

=head4 Input (Params::Validate::Strict compatible)

    {
        got => { type => SCALAR | ARRAYREF | HASHREF | OBJECT, optional => 1 },
        exp => { type => SCALAR | ARRAYREF | HASHREF | OBJECT, optional => 1 },
    }

=head4 Output (Return::Set compatible)

    {
        result => STRING,   # explanation text
    }

=cut

sub explain {
	my ($got, $exp) = @_;

	# Normalize undef for scalar handling
	$got = '' unless defined $got;
	$exp = '' unless defined $exp;

	# Scalar vs scalar
	if (!ref $got && !ref $exp) {
		my $pos = _first_diff_pos($got, $exp);
		return "Values are identical: $got\n" if $pos == -1;

		my $out = '';
		$out .= "Scalar comparison failed:\n";
		$out .= "  Got:	  $got\n";
		$out .= "  Expected: $exp\n";
		$out .= "  First difference at index $pos\n";
		return $out;
	}

	# Deep structures: arrays, hashes, blessed refs
	my $gref = ref $got;
	my $eref = ref $exp;

	# Array refs
	if ($gref eq 'ARRAY' && $eref eq 'ARRAY') {
		return "Values are identical\n" if @$got == 0 && @$exp == 0;
		my $out = "Array diff:\n";

		# find differing index
		my $i = 0;
		$i++ while $i < @$got && $got->[$i] eq $exp->[$i];

	if ($i < @$got) {
		$out .= "  $got->[$i] vs $exp->[$i]\n";
	}

	$out .= "  Got:	  " . _dump($got) . "\n";
	$out .= "  Expected: " . _dump($exp) . "\n";
	return $out;
}

	if ($gref eq 'HASH' && $eref eq 'HASH') {
		return "Values are identical\n" if !keys(%$got) && !keys(%$exp);
		my $out = "Hash diff:\n";

		# detect nested array diffs
		if (grep { ref($_) eq 'ARRAY' } values %$got, values %$exp) {
			$out .= "Array diff:\n";
		}

		$out .= "  Got:	  " . _dump($got) . "\n";
		$out .= "  Expected: " . _dump($exp) . "\n";
		return $out;
	}

	# Blessed refs
	if (blessed($got) || blessed($exp)) {
		my $out = '';
		$out .= "Blessed reference diff:\n";
		$out .= "  Got:	  " . _dump($got) . "\n";
		$out .= "  Expected: " . _dump($exp) . "\n";
		return $out;
	}

	# Fallback for other refs / mixed types
	my $out = '';
	$out .= "Deep structure comparison failed:\n";
	$out .= "  Got:	  " . _dump($got) . "\n";
	$out .= "  Expected: " . _dump($exp) . "\n";
	return $out;
}

#-----------------------------------------------------------------------
# _dump()
# Entry criteria:
#   - Receives any Perl value.
# Exit status:
#   - Returns a compact Data::Dumper string.
# Side effects:
#   - None.
# Notes:
#   - Used internally for deep structure formatting.
#-----------------------------------------------------------------------
sub _dump {
	my ($v) = @_;
	local $Data::Dumper::Terse  = 1;
	local $Data::Dumper::Indent = 0;
	return Data::Dumper::Dumper($v);
}

#------------------------------------------------------------
# Detect Test::More failure diagnostics
#------------------------------------------------------------
#-----------------------------------------------------------------------
# _looks_like_test_more_failure()
# Entry criteria:
#   - Receives raw diag() messages.
# Exit status:
#   - Returns boolean.
# Side effects:
#   - None.
# Notes:
#   - Detects Test::More failure diagnostics.
#-----------------------------------------------------------------------
sub _looks_like_test_more_failure {
	my @msg = @_;

	# Typical Test::More failure lines:
	#   Failed test '...'
	#   at file.t line N.
	#		  got: 'foo'
	#	 expected: 'bar'

	return 1 if $msg[0] =~ /^Failed test/;
	return 1 if $msg[0] =~ /^#\s+got:/;
	return 1 if $msg[0] =~ /^#\s+expected:/;

	return 0;
}

#------------------------------------------------------------
# Emit enhanced diagnostics
#-----------------------------------------------------------------------
# _emit_explain()
# Entry criteria:
#   - Receives Test::More failure diagnostics.
# Exit status:
#   - Emits structured diagnostics via diag().
# Side effects:
#   - Produces TAP output.
# Notes:
#   - Chooses scalar or deep diff mode.
#-----------------------------------------------------------------------
sub _emit_explain {
	my @msg = @_;

	# Split multi-line diag strings into individual lines
	@msg = map { split /\n/ } @msg;

	my ($got, $exp) = _extract_got_expected(@msg);

	if (_is_deep($got) || _is_deep($exp)) {
		_explain_deep($got, $exp);
	}
	else {
		_explain_scalar($got, $exp);
	}
}

#------------------------------------------------------------
# Extract got/expected values from Test::More diagnostics
#-----------------------------------------------------------------------
# _extract_got_expected()
# Entry criteria:
#   - Receives Test::More diagnostic lines.
# Exit status:
#   - Returns ($got, $exp) strings.
# Side effects:
#   - None.
# Notes:
#   - Extracts raw values from Test::More output.
#-----------------------------------------------------------------------
sub _extract_got_expected {
	my @msg = @_;

	my ($got, $exp);

	for my $line (@msg) {
		if ($line =~ /#\s*got:\s*(.*)$/) {
			$got = $1;
		}
		if ($line =~ /#\s*expected:\s*(.*)$/) {
			$exp = $1;
		}
	}

	$got = '' unless defined $got;
$exp = '' unless defined $exp;

	return ($got, $exp);
}


#------------------------------------------------------------
# Detect deep structures
#-----------------------------------------------------------------------
# _is_deep()
# Entry criteria:
#   - Receives a string representation of a value.
# Exit status:
#   - Returns boolean.
# Side effects:
#   - None.
# Notes:
#   - Detects array, hash, or blessed reference dumps.
#-----------------------------------------------------------------------
sub _is_deep {
	my ($v) = @_;
	return 0 unless defined $v;

	# hash dump
	return 1 if index($v, '{') == 0;

	# array dump
	return 1 if index($v, '[') == 0;

	# blessed ref
	return 1 if $v =~ /^bless/;

	return 0;
}


#------------------------------------------------------------
# Scalar diff with hints
#-----------------------------------------------------------------------
# _explain_scalar()
# Entry criteria:
#   - Receives two scalar strings.
# Exit status:
#   - Emits diagnostics via diag().
# Side effects:
#   - Produces TAP output.
# Notes:
#   - Includes context and hints.
#-----------------------------------------------------------------------
sub _explain_scalar {
	my ($got, $exp) = @_;

	# Normalize undef to empty string for diffing
	$got = '' unless defined $got;
	$exp = '' unless defined $exp;

	$TB->diag("Scalar comparison failed:");
	$TB->diag("  Got:	  $got");
	$TB->diag("  Expected: $exp");

	my $i = _first_diff_pos($got, $exp);
	if ($i >= 0) {
		$TB->diag("  First difference at index $i");
		_emit_scalar_context($got, $exp, $i);
		_emit_scalar_hints($got, $exp);
	}
}

#-----------------------------------------------------------------------
# _first_diff_pos()
# Entry criteria:
#   - Receives two scalar strings.
# Exit status:
#   - Returns index of first differing character, or -1.
# Side effects:
#   - None.
# Notes:
#   - Used for scalar diffing.
#-----------------------------------------------------------------------
sub _first_diff_pos {
	my ($a, $b) = @_;
		$a = '' unless defined $a;
	$b = '' unless defined $b;
	my $len = length($a) < length($b) ? length($a) : length($b);

	for my $i (0 .. $len - 1) {
		return $i if substr($a, $i, 1) ne substr($b, $i, 1);
	}

	return $len if length($a) != length($b);
	return -1;
}

#-----------------------------------------------------------------------
# _emit_scalar_context()
# Entry criteria:
#   - Receives two strings and a mismatch index.
# Exit status:
#   - Emits diagnostics.
# Side effects:
#   - Produces TAP output.
# Notes:
#   - Shows context around mismatch.
#-----------------------------------------------------------------------
sub _emit_scalar_context {
	my ($got, $exp, $i) = @_;

	  $got = '' unless defined $got;
	$exp = '' unless defined $exp;

	my $ctx = 20;
	my $g = substr($got, $i, $ctx);
	my $e = substr($exp, $i, $ctx);

	$TB->diag("  Context around mismatch:");
	$TB->diag("	Got:	  ...$g");
	$TB->diag("	Expected: ...$e");
}

#-----------------------------------------------------------------------
# _emit_scalar_hints()
# Entry criteria:
#   - Receives two strings.
# Exit status:
#   - Emits diagnostics.
# Side effects:
#   - Produces TAP output.
# Notes:
#   - Provides heuristic hints.
#-----------------------------------------------------------------------
sub _emit_scalar_hints {
	my ($got, $exp) = @_;

	$TB->diag("  Possible causes:");

	if (length($got) != length($exp)) {
		$TB->diag("	• Length differs (" . length($got) . " vs " . length($exp) . ")");
	}

	if ($got =~ /^\s/ || $got =~ /\s$/ || $exp =~ /^\s/ || $exp =~ /\s$/) {
		$TB->diag("	• Leading/trailing whitespace differs");
	}

	if (lc($got) eq lc($exp) && $got ne $exp) {
		$TB->diag("	• Case differs (consider using lc/uc)");
	}

	if ($got =~ /[^\x00-\x7F]/ || $exp =~ /[^\x00-\x7F]/) {
		$TB->diag("	• Unicode mismatch (check encoding)");
	}
}

#------------------------------------------------------------
# Deep diff with hints
#-----------------------------------------------------------------------
# _explain_deep()
# Entry criteria:
#   - Receives two deep structure dumps.
# Exit status:
#   - Emits diagnostics.
# Side effects:
#   - Produces TAP output.
# Notes:
#   - Delegates to _emit_deep_hints().
#-----------------------------------------------------------------------
sub _explain_deep {
	my ($got, $exp) = @_;

	$TB->diag("Deep structure comparison failed:");
	$TB->diag("  Got:	  $got");
	$TB->diag("  Expected: $exp");

	_emit_deep_hints($got, $exp);
}

#-----------------------------------------------------------------------
# _emit_deep_hints()
# Entry criteria:
#   - Receives two deep structure dumps.
# Exit status:
#   - Emits diagnostics.
# Side effects:
#   - Produces TAP output.
# Notes:
#   - Detects array length differences, missing keys, and blessedness.
#-----------------------------------------------------------------------
sub _emit_deep_hints {
	my ($got, $exp) = @_;

	$TB->diag("  Possible causes:");

	if ($got =~ /^

\[/ && $exp =~ /^

\[/) {
		my $gl = () = $got =~ /,/g;
		my $el = () = $exp =~ /,/g;
		if ($gl != $el) {
			$TB->diag("	• Array length differs");
		}
	}

	if ($got =~ /^\{/ && $exp =~ /^\{/) {
		my %g = _extract_keys($got);
		my %e = _extract_keys($exp);

		for my $k (keys %g) {
			$TB->diag("	• Extra key in got: $k") unless exists $e{$k};
		}
		for my $k (keys %e) {
			$TB->diag("	• Missing key in got: $k") unless exists $g{$k};
		}
	}

	if ($got =~ /^bless/ xor $exp =~ /^bless/) {
		$TB->diag("	• One value is blessed, the other is not");
	}
}

#-----------------------------------------------------------------------
# _extract_keys()
# Entry criteria:
#   - Receives a hash dump string.
# Exit status:
#   - Returns a hash of keys.
# Side effects:
#   - None.
# Notes:
#   - Used for deep hash diffing.
#-----------------------------------------------------------------------
sub _extract_keys {
	my ($dump) = @_;
	my %keys;
	while ($dump =~ /'([^']+)'/g) {
		$keys{$1} = 1;
	}
	return %keys;
}

1;

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>

=head1 BUGS

=head1 SEE ALSO

=head1 REPOSITORY

L<https://github.com/nigelhorne/Test-Most-Explain>

=head1 SUPPORT

This module is provided as-is without any warranty.

Please report any bugs or feature requests to C<bug-test-most-explain at rt.cpan.org>,
or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Most-Explain>.
I will be notified, and then you'll
automatically be notified of progress on your bug as I make changes.

You can find documentation for this module with the perldoc command.

    perldoc Test::Most::Explain

You can also look for information at:

=over 4

=item * MetaCPAN

L<https://metacpan.org/dist/Test-Most-Explain>

=item * RT: CPAN's request tracker

L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=Test-Most-Explain>

=item * CPAN Testers' Matrix

L<http://matrix.cpantesters.org/?dist=Test-Most-Explain>

=item * CPAN Testers Dependencies

L<http://deps.cpantesters.org/?module=Test::Most::Explain>

=back

=head1 LICENCE AND COPYRIGHT

Copyright 2026 Nigel Horne.

Usage is subject to licence terms.

The licence terms of this software are as follows:

=over 4

=item * Personal single user, single computer use: GPL2

=item * All other users (including Commercial, Charity, Educational, Government)
  must apply in writing for a licence for use from Nigel Horne at the
  above e-mail.

=back

=cut

1;
