Database-Join
17 results

 view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN 

BEGIN {
	eval { require Database::Abstraction };
	plan skip_all => 'Database::Abstraction required' if $@;
	plan tests => 134;
	use_ok('Database::Join');
}

# ---------------------------------------------------------------------------
# Readonly attack payloads and structural constants
# ---------------------------------------------------------------------------
Readonly::Scalar my $JC          => 'entry';    # canonical join column
Readonly::Scalar my $K_ALPHA     => 'k001';
Readonly::Scalar my $K_BETA      => 'k002';
Readonly::Scalar my $K_GAMMA     => 'k003';
Readonly::Scalar my $KEY_ZERO    => '0';        # false-but-defined join key

Readonly::Scalar my $ERR_NO_DBS      => qr/At least one Database::Abstraction/;
Readonly::Scalar my $ERR_INVALID_DB  => qr/does not support the selectall_arrayref/;
Readonly::Scalar my $ERR_MISSING_JC  => qr/is absent from databases/;
Readonly::Scalar my $ERR_REMOVE_JC   => qr/Cannot remove join_column/;
Readonly::Scalar my $ERR_PRIVATE     => qr/cannot call private method/;
Readonly::Scalar my $ERR_UNKNOWN_COL => qr/unknown column/;
Readonly::Scalar my $ERR_QUERY       => qr/query\(\) chained builder is not supported/;
Readonly::Scalar my $ERR_EXECUTE     => qr/execute\(\) raw SQL is not supported/;
Readonly::Scalar my $ERR_HEAP        => qr/\(join_map\[0\] must be a string\)/;

# ---------------------------------------------------------------------------
# MockEdgeDA: configurable in-process stub with explicit failure modes.
#
# Constructor options:
#   cols      => \@list     -- columns() return value
#   rows      => \@hrefs    -- data for selectall_arrayref
#   id        => 'colname'  -- internal primary-key field (_autoload_pk source)
#   updated   => $epoch     -- updated() return value
#   schema    => \%or_undef -- schema() return value (undef to simulate failure)
#   return    => $anything  -- literal return from selectall_arrayref (overrides rows)
#   croak_msg => 'text'     -- selectall_arrayref will croak with this message
# ---------------------------------------------------------------------------
## no critic (Modules::ProhibitMultiplePackages)
{
	package MockEdgeDA;
	use parent -norequire, 'Database::Abstraction';
	use Carp qw(croak);

	sub new {
		my ($class, %args) = @_;
		return bless {
			id      => $args{id}        // 'entry',
			_cols   => $args{cols}      // ['entry'],
			_rows   => $args{rows}      // [],
			_schema => $args{schema},           # deliberately no default -- undef is valid input
			_ts     => $args{updated}   // 1_000_000,
			_return => $args{return},
			_do_ret => (exists $args{return}),  # distinguish return=>undef from absent key
			_croak  => $args{croak_msg},
		}, $class;
	}

	sub columns   { return $_[0]->{_cols} }
	sub schema    { return $_[0]->{_schema} }
	sub updated   { return $_[0]->{_ts} }
	sub set_logger { $_[0]->{_logger} = $_[1]; return $_[0] }

	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		croak($self->{_croak})   if $self->{_croak};
		return $self->{_return}  if $self->{_do_ret};
		my @rows = @{ $self->{_rows} };
		for my $col (keys %{ $criteria // {} }) {
			my $val = $criteria->{$col};
			if (ref($val) eq 'HASH') {
				for my $op (keys %{$val}) {
					my $v = $val->{$op};
					if    ($op eq '>')  { @rows = grep { defined $_->{$col} && $_->{$col} >  $v } @rows }
					elsif ($op eq '<')  { @rows = grep { defined $_->{$col} && $_->{$col} <  $v } @rows }
					elsif ($op eq '>=') { @rows = grep { defined $_->{$col} && $_->{$col} >= $v } @rows }
					elsif ($op eq '<=') { @rows = grep { defined $_->{$col} && $_->{$col} <= $v } @rows }
					elsif ($op eq '!=') { @rows = grep { defined $_->{$col} && $_->{$col} != $v } @rows }
				}
			} elsif (defined $val) {
				@rows = grep { defined $_->{$col} && $_->{$col} eq $val } @rows;
			} else {
				@rows = grep { !defined $_->{$col} } @rows;
			}
		}
		return \@rows;
	}

	sub DESTROY {}
}

# MutateCriteriaDA: simulates a hostile DA that mutates the criteria hashref
# it receives.  Used to prove that the broadcast shallow-copy mechanism
# prevents one DA from corrupting the criteria delivered to sibling databases.
{
	package MutateCriteriaDA;
	use parent -norequire, 'Database::Abstraction';

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

	sub columns   { return $_[0]->{_cols} }
	sub schema    { return {} }
	sub updated   { return 1 }
	sub set_logger { $_[0]->{_logger} = $_[1]; return $_[0] }

	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		# HOSTILE: overwrite the '>' operator inside the entry criteria hashref to
		# attempt to corrupt sibling databases' criteria for the same broadcast key.
		if (ref($criteria) eq 'HASH' && ref($criteria->{entry}) eq 'HASH') {
			$criteria->{entry}{'>'} = 999_999;
		}
		return $self->{_rows};
	}

	sub DESTROY {}
}

# ---------------------------------------------------------------------------
# Helper: build a minimal two-DB join with stock fixtures.
# Returns ($join, $primary_da, $secondary_da).
# ---------------------------------------------------------------------------
sub _minimal_join {
	my (%opts) = @_;
	my $prim = MockEdgeDA->new(
		cols => ['entry', 'name'],
		rows => [
			{ entry => $K_ALPHA, name => 'Alice' },
			{ entry => $K_BETA,  name => 'Bob'   },
		],
	);
	my $sec = MockEdgeDA->new(
		cols => ['entry', 'score'],
		rows => [
			{ entry => $K_ALPHA, score => 90 },
			{ entry => $K_BETA,  score => 70 },
		],
	);
	my $j = Database::Join->new(
		databases   => [$prim, $sec],
		join_column => $JC,
		%opts,
	);
	return ($j, $prim, $sec);
}

# ===========================================================================
# Section 1: Constructor hostility
# ===========================================================================

subtest 'constructor: empty databases arrayref croaks error_no_databases' => sub {
	# An empty arrayref satisfies the type check but fails the emptiness guard.
	throws_ok { Database::Join->new(databases => []) }
		$ERR_NO_DBS, 'empty databases => [] croaks';
};

subtest 'constructor: undef element in databases croaks error_invalid_db' => sub {
	throws_ok { Database::Join->new(databases => [undef]) }
		$ERR_INVALID_DB, 'databases => [undef] croaks';
};

subtest 'constructor: unblessed scalar in databases croaks' => sub {
	throws_ok { Database::Join->new(databases => [42]) }

t/edge_cases.t  view on Meta::CPAN 

	);
	my $sec = MockEdgeDA->new(
		cols => ['entry', 'score'],
		rows => [
			{ entry => $K_ALPHA, score => 95 },  # passes filter score > 80
			{ entry => $K_BETA,  score => 50 },  # fails filter score > 80
		],
	);
	my $j = Database::Join->new(
		databases   => [$prim, $sec],
		join_column => $JC,
		join_type   => 'left',
		filters     => { 1 => { score => { '>' => 80 } } },
	);
	$j->remove_column('score');  # hide the filtered column from caller output
	my $rows = $j->selectall_arrayref();
	# Alice (score 95) passes the filter; Bob (score 50) does not.
	# Even though 'score' is invisible to the caller, the filter must still apply.
	is scalar @{$rows}, 1,             'filter still restricts after remove_column';
	is $rows->[0]{name}, 'Alice',      'Alice (score 95) survives the hidden filter';
	ok !exists($rows->[0]{score}),     'score column absent from output as expected';
};

# ===========================================================================
# Section 16: SQLite backend hostile inputs and security (8 subtests)
#
# The SQLite backend caches source data in a per-object File::Temp file and
# uses parameterised SQL queries.  These tests probe eight failure modes that
# could cause crashes, data corruption, or security breaches:
#
#   (1) tmpdir is a regular file → File::Temp croaks cleanly
#   (2) DBI::connect patched to return undef → error_sqlite_connect
#   (3) SQL injection via criteria VALUE → safely bound (not interpolated)
#   (4) Two concurrent join objects → independent temp files in same tmpdir
#   (5) DESTROY without any prior query → no crash (no cache to disconnect)
#   (6) DA croaks during cache build → exception propagates, no dangling .db file
#   (7) max_array_rows=0 with a DA that defines count() → SQLite path taken
#   (8) DA returns empty result set on SQLite path → empty arrayref (not crash)
# ===========================================================================

# CountableEdgeDA: variant of MockEdgeDA that defines count() in its own
# package so that `defined &{"${pkg}::count"}` is true.  Required for the
# max_array_rows threshold probe, which avoids calling inherited count() to
# prevent uninitialised-value warnings from Database::Abstraction::count($entry).
{
	package CountableEdgeDA;
	use parent -norequire, 'Database::Abstraction';

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

	sub columns           { return $_[0]->{_cols} }
	sub schema            { return {} }
	sub updated           { return $_[0]->{_ts} }
	sub set_logger        { $_[0]->{_logger} = $_[1]; return $_[0] }
	sub count             { return scalar @{ $_[0]->{_rows} } }
	sub selectall_arrayref {
		my ($self, $criteria) = @_;
		my @rows = @{ $self->{_rows} };
		for my $col (keys %{ $criteria // {} }) {
			my $val = $criteria->{$col};
			next if ref $val;
			@rows = grep { defined $_->{$col} && $_->{$col} eq $val } @rows;
		}
		return \@rows;
	}
	sub DESTROY {}
}

Readonly::Scalar my $BAD_DIR => File::Spec->catfile(
	File::Spec->tmpdir, '__edge_cases_nonexistent_dir_xyz__'
);

subtest 'sqlite backend: tmpdir pointing to a regular file → File::Temp croaks cleanly' => sub {
	# File::Temp->new(DIR => $path) requires $path to be an existing directory.
	# When $path is a regular file, File::Temp must croak with a clear message
	# rather than silently writing into an impossible path or segfaulting.
	#
	# Proof: create a real temp file, then pass its path as tmpdir.
	my $tmp_file = File::Temp->new(UNLINK => 1);
	my $file_path = $tmp_file->filename;
	my $db_a = MockEdgeDA->new(
		cols => ['entry', 'x'],
		rows => [{ entry => $K_ALPHA, x => 1 }],
	);
	my $j = Database::Join->new(
		databases   => [$db_a],
		join_column => $JC,
		backend     => 'sqlite',
		tmpdir      => $file_path,   # a regular file, not a directory
	);
	throws_ok { $j->selectall_arrayref() }
		qr/does not exist|not.*director|cannot.*creat|POSIX/i,
		'File::Temp croaks when tmpdir is a regular file';
};

subtest 'sqlite backend: DBI::connect returning undef → error_sqlite_connect' => sub {
	# Monkey-patch DBI::connect to simulate a driver failure (e.g. missing
	# DBD::SQLite, corrupt db, or permission denied on the temp file path).
	# The module must croak with error_sqlite_connect rather than dereferencing
	# a null handle and generating an uninformative "can't call method on undef".
	#
	# Technique from CLAUDE.md: patch and restore around a scoped eval.
	my $db_a = MockEdgeDA->new(
		cols => ['entry', 'x'],
		rows => [{ entry => $K_ALPHA, x => 1 }],
	);
	my $j = Database::Join->new(
		databases => [$db_a],
		join_column => $JC,
		backend   => 'sqlite',
	);
	require DBI;
	my $orig = \&DBI::connect;

t/edge_cases.t  view on Meta::CPAN 


subtest 'sqlite backend: max_array_rows=0 with countable DA forces SQLite path' => sub {
	# When max_array_rows => 0, any non-empty dataset (total > 0) pushes the
	# 'auto' backend onto the SQLite path.  Proof via the bad-tmpdir technique
	# from CLAUDE.md: the SQLite path calls File::Temp, which dies for a missing
	# directory; the array path never calls File::Temp and succeeds.
	my $da = CountableEdgeDA->new(
		cols => ['entry', 'x'],
		rows => [{ entry => $K_ALPHA, x => 1 }],   # 1 row → total(1) > max_array_rows(0)
	);
	my $j = Database::Join->new(
		databases      => [$da],
		join_column    => $JC,
		backend        => 'auto',
		max_array_rows => 0,          # force SQLite path for any non-empty dataset
		tmpdir         => $BAD_DIR,   # File::Temp will die here if SQLite path is taken
	);
	throws_ok { $j->selectall_arrayref() }
		qr/does not exist|not.*director|cannot.*creat/i,
		'max_array_rows=0 forces SQLite path (File::Temp dies on bad tmpdir as expected)';
};

subtest 'sqlite backend: DA returns no rows → empty arrayref (not crash or undef)' => sub {
	# A DA whose selectall_arrayref returns [] (no rows at all) is valid on the
	# SQLite path.  _build_sqlite_cache must create an empty table, and the SQL
	# JOIN must return an empty result set -- not crash, not return undef.
	my $empty_da = MockEdgeDA->new(
		cols => ['entry', 'score'],
		rows => [],   # no rows at all
	);
	my $j = Database::Join->new(
		databases => [$empty_da], join_column => $JC, backend => 'sqlite',
	);
	my $rows;
	lives_ok { $rows = $j->selectall_arrayref() }
		'query lives when DA has no rows on the SQLite path';
	ok ref($rows) eq 'ARRAY', 'result is an arrayref (not undef)';
	is scalar @{$rows}, 0, 'empty arrayref returned (no rows, no crash)';
};

# ---------------------------------------------------------------------------
# Package stubs for 0.007.0 edge-case sections (S17-S23)
# ---------------------------------------------------------------------------

# ThrowSchemaDA: DA whose schema() throws, to probe _validate_schema_types
# resilience -- the exception must be silently swallowed, not propagated.
{
	package ThrowSchemaDA;
	use parent -norequire, 'Database::Abstraction';
	use Carp qw(croak);
	sub new {
		my ($class, %args) = @_;
		return bless {
			id    => $args{id}   // 'entry',
			_cols => $args{cols} // ['entry'],
			_rows => $args{rows} // [],
		}, $class;
	}
	sub columns            { return $_[0]->{_cols} }
	sub schema             { croak 'schema() simulated failure' }
	sub updated            { return 1 }
	sub set_logger         { $_[0]->{_logger} = $_[1]; return $_[0] }
	sub selectall_arrayref { return $_[0]->{_rows} }
	sub DESTROY {}
}

# BareEdgeDA: minimal duck-type DA with no updated() method at all.
# Proves updated() resilience when a component has no timestamp support.
{
	package BareEdgeDA;
	sub new {
		my ($class, %args) = @_;
		return bless {
			_cols => $args{cols} // ['entry'],
			_rows => $args{rows} // [],
		}, $class;
	}
	sub columns            { return $_[0]->{_cols} }
	sub schema             { return {} }
	sub set_logger         { $_[0]->{_logger} = $_[1]; return $_[0] }
	sub selectall_arrayref { return $_[0]->{_rows} }
	sub DESTROY {}
	# No updated() method -- deliberately absent
}

# ThrowUpdEdgeDA: DA whose updated() throws, to probe updated() resilience.
{
	package ThrowUpdEdgeDA;
	use parent -norequire, 'MockEdgeDA';
	use Carp qw(croak);
	sub updated { croak 'simulated updated() failure' }
	sub DESTROY {}
}

# ===========================================================================
# S17: limit / offset -- hostile inputs
# ===========================================================================
# 0.007.0: limit => N (positive integer), offset => M (non-negative integer).
# Invalid values emit carp and are treated as absent (no crash, no die).

subtest 'limit/offset: negative limit carps and is treated as absent' => sub {
	# Negative limit is not a positive integer; the module must carp and ignore it.
	my ($j) = _minimal_join();
	my $rows;
	warning_like { $rows = $j->selectall_arrayref(limit => -1) }
		qr/limit/i, 'negative limit emits a carp warning';
	is scalar @{$rows}, 2, 'all rows returned when limit is invalid';
};

subtest 'limit/offset: undef limit is silently ignored' => sub {
	my ($j) = _minimal_join();
	my $rows;
	lives_ok { $rows = $j->selectall_arrayref(limit => undef) }
		'undef limit does not crash';
	is scalar @{$rows}, 2, 'all rows returned when limit is undef';
};

subtest 'limit/offset: non-integer string limit carps and is ignored' => sub {
	my ($j) = _minimal_join();
	my $rows;
	warning_like { $rows = $j->selectall_arrayref(limit => 'banana') }
		qr/limit/i, 'non-integer string limit emits carp';
	is scalar @{$rows}, 2, 'all rows returned for non-integer limit';
};

subtest 'limit/offset: negative offset carps and is treated as absent' => sub {
	my ($j) = _minimal_join();
	my $rows;
	warning_like { $rows = $j->selectall_arrayref(offset => -3) }
		qr/offset/i, 'negative offset emits carp';
	is scalar @{$rows}, 2, 'all rows returned when offset is invalid';
};

subtest 'limit/offset: offset equal to total row count returns empty arrayref' => sub {
	# With offset == N and N rows total, no rows remain after skipping.
	my ($j) = _minimal_join();   # 2-row join
	my $rows;
	lives_ok { $rows = $j->selectall_arrayref(offset => 2) }
		'offset == row count does not crash';
	is scalar @{$rows}, 0, 'empty arrayref when offset equals total row count';
};

subtest 'limit/offset: offset far beyond row count returns empty arrayref' => sub {
	my ($j) = _minimal_join();
	my $rows;
	lives_ok { $rows = $j->selectall_arrayref(offset => 999_999) }
		'offset far beyond row count does not crash';
	is scalar @{$rows}, 0, 'empty arrayref when offset greatly exceeds row count';
};

# ===========================================================================



( run in 0.350 second using v1.01-cache-2.11-cpan-7da0f45c409 )