view release on metacpan or  search on metacpan

t/collision-prefix.t  view on Meta::CPAN

#!/usr/bin/perl

# Tests for the collision_prefix constructor parameter.
#
# Verifies that colliding secondary database columns are published under
# "$prefix.$col" while preserving the original column from earlier databases,
# that non-colliding columns and the join_column pass through without any
# prefix, and that the previous last-wins behaviour is unchanged when no
# prefix is configured.

use strict;
use warnings;

use Test::Most;
use Readonly;

use_ok('Database::Join');

# ---------------------------------------------------------------------------
# Inline component DA — no disk I/O required; supports equality and operator
# criteria on any column via a simple row-scan.
# ---------------------------------------------------------------------------
{
	package CollDA;
	use parent -norequire, 'Database::Abstraction';

	sub new {
		my ($class, %args) = @_;
		return bless {
			cols    => $args{cols}    // ['entry'],
			rows    => $args{rows}    // [],
			schema  => $args{schema}  // {},
			updated => $args{updated} // 1,
		}, $class;
	}

	sub columns    { return $_[0]->{cols} }
	sub schema     { return $_[0]->{schema} }
	sub updated    { return $_[0]->{updated} }
	sub set_logger { return $_[0] }

	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 (!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 {}
}

# ---------------------------------------------------------------------------
# Constants — no magic strings/numbers in the test body
# ---------------------------------------------------------------------------
Readonly::Scalar my $ENTRY_W  => 'w';
Readonly::Scalar my $ENTRY_G  => 'g';
Readonly::Scalar my $AMOUNT_W => 10;
Readonly::Scalar my $AMOUNT_G => 20;
Readonly::Scalar my $PRICE_W  => 5;
Readonly::Scalar my $PRICE_G  => 15;
Readonly::Scalar my $NOTE_L_W => 'left-notes-w';
Readonly::Scalar my $NOTE_L_G => 'left-notes-g';
Readonly::Scalar my $NOTE_R_W => 'right-notes-w';
Readonly::Scalar my $NOTE_R_G => 'right-notes-g';
Readonly::Scalar my $PREFIX_B => 'b';

# ---------------------------------------------------------------------------
# Fixture builders — construct fresh DA objects for each subtest to avoid
# shared-state interactions between subtests.
# ---------------------------------------------------------------------------

sub left_da {
	# Primary: entry (join key), amount (unique), notes (collides with right)
	return CollDA->new(
		cols   => [qw(entry amount notes)],
		rows   => [
			{ entry => $ENTRY_W, amount => $AMOUNT_W, notes => $NOTE_L_W },
			{ entry => $ENTRY_G, amount => $AMOUNT_G, notes => $NOTE_L_G },
		],
		schema => {