view release on metacpan or  search on metacpan

t/path.t  view on Meta::CPAN

#!/usr/bin/perl

# Control-Flow Path Coverage for Database::Join.
# One test case per uniquely identifiable execution path through the CFG.

use strict;
use warnings;

use Test::Most tests => 85;
use Readonly;
use Scalar::Util qw(blessed refaddr);

use_ok('Database::Join');

# ---------------------------------------------------------------------------
# Inline test doubles
# ---------------------------------------------------------------------------

{
	package PathDA;
	use parent -norequire, 'Database::Abstraction';

	sub new {
		my ($class, %a) = @_;
		return bless {
			cols    => $a{cols}    // ['entry'],
			rows    => $a{rows}    // [],
			id      => $a{id},		# may be undef to test fallback path
			schema  => $a{schema}  // {},
			updated => $a{updated} // 1,
			_logger => undef,
		}, $class;
	}
	sub columns          { return $_[0]->{cols} }
	sub schema           { return $_[0]->{schema} }	# may return undef explicitly
	sub updated          { return $_[0]->{updated} }
	sub set_logger       { $_[0]->{_logger} = $_[1]; return $_[0] }
	sub get_logger       { return $_[0]->{_logger} }

	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		$criteria //= {};
		my @out;
		ROW: for my $row (@{ $self->{rows} }) {
			for my $col (keys %{$criteria}) {
				my $val = $criteria->{$col};
				if (ref $val eq 'HASH') {
					for my $op (keys %{$val}) {
						my $rhs = $val->{$op};
						if    ($op eq '>')  { next ROW unless defined $row->{$col} && $row->{$col} >  $rhs }
						elsif ($op eq '<')  { next ROW unless defined $row->{$col} && $row->{$col} <  $rhs }
						elsif ($op eq '>=') { next ROW unless defined $row->{$col} && $row->{$col} >= $rhs }
						elsif ($op eq '<=') { next ROW unless defined $row->{$col} && $row->{$col} <= $rhs }
						elsif ($op eq '!=') { next ROW unless defined $row->{$col} && $row->{$col} != $rhs }
					}
				} elsif (!defined $val) {
					next ROW if defined $row->{$col};
				} else {
					next ROW unless defined $row->{$col} && $row->{$col} eq $val;
				}
			}
			push @out, { %{$row} };
		}
		return \@out;
	}

	sub DESTROY {}
}

# DA with a real column method for AUTOLOAD direct-delegation path
{
	package PathDirectDA;
	use parent -norequire, 'Database::Abstraction';

	sub new {
		my ($class, %a) = @_;
		return bless {
			cols    => $a{cols}  // ['entry', 'score'],
			rows    => $a{rows}  // [],
			id      => $a{id}    // 'entry',
			_calls  => 0,
			_logger => undef,
		}, $class;
	}
	sub columns    { return $_[0]->{cols} }
	sub schema     { return {} }
	sub updated    { return 1 }
	sub set_logger { $_[0]->{_logger} = $_[1]; return $_[0] }
	sub get_logger { return $_[0]->{_logger} }
	sub calls      { return $_[0]->{_calls} }

	# Real column method — AUTOLOAD delegates here on the direct path
	sub score {
		my ($self, @args) = @_;
		$self->{_calls}++;
		return wantarray ? (90, 70) : 90;
	}

	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		$criteria //= {};
		my @out;
		ROW: for my $row (@{ $self->{rows} }) {
			for my $col (keys %{$criteria}) {
				my $val = $criteria->{$col};
				if (ref $val eq 'HASH') {
					for my $op (keys %{$val}) {
						my $rhs = $val->{$op};
						if    ($op eq '>')  { next ROW unless defined $row->{$col} && $row->{$col} >  $rhs }
						elsif ($op eq '<')  { next ROW unless defined $row->{$col} && $row->{$col} <  $rhs }
						elsif ($op eq '>=') { next ROW unless defined $row->{$col} && $row->{$col} >= $rhs }
						elsif ($op eq '<=') { next ROW unless defined $row->{$col} && $row->{$col} <= $rhs }
						elsif ($op eq '!=') { next ROW unless defined $row->{$col} && $row->{$col} != $rhs }
					}
				} elsif (!defined $val) {
					next ROW if defined $row->{$col};
				} else {
					next ROW unless defined $row->{$col} && $row->{$col} eq $val;
				}
			}
			push @out, { %{$row} };
		}
		return \@out;
	}

	sub DESTROY {}
}

# i18n mock that has translate → exercises the translate branch in _msg
{
	package MockI18N;
	sub new       { bless { keys => [] }, shift }
	sub translate { my ($self, $key, @a) = @_; push @{$self->{keys}}, $key; return "TRANSLATED:$key" }
}

# i18n mock WITHOUT translate → exercises the fallback-to-%MESSAGES branch
{
	package MockI18NBlind;
	sub new { bless {}, shift }
	# deliberately omits translate
}

# Logger mock with set_logger/get_logger — verifies propagation paths
{
	package MockLogger;
	sub new { bless {}, shift }
	sub debug {}