Database-Join
view release on metacpan or search on metacpan
lib/Database/Join.pm view on Meta::CPAN
=head3 EXAMPLE
my $last_modified = $join->updated();
if ($last_modified > $my_cache_timestamp) {
$my_cache = $join->selectall_arrayref();
$my_cache_timestamp = $last_modified;
}
=cut
sub updated {
my ($self) = @_;
return max(map { $_->updated() } @{ $self->{_dbs} });
}
=head2 set_logger
=head3 SYNOPSIS
$join->set_logger($log);
t/data-flow.t view on Meta::CPAN
_cols => $args{cols} // ['entry'],
_rows => $args{rows} // [],
_schema => $args{schema} // {},
_ts => $args{updated} // 1_000_000,
_received => [], # [ { hashref => ..., refaddr => ... }, ... ]
}, $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) = @_;
push @{ $self->{_received} }, {
hashref => $criteria,
refaddr => Scalar::Util::refaddr($criteria),
};
# Simple equality filter (no operator hashrefs needed for DU tests)
my @rows = @{ $self->{_rows} };
t/data-flow.t view on Meta::CPAN
id => $args{id} // 'entry',
_cols => $args{cols} // ['entry'],
_rows => $args{rows} // [],
_schema => $args{schema} // {},
_ts => $args{updated} // 1_000_000,
}, $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 { return $_[0]->{_rows} } # always returns all rows
sub DESTROY {}
}
# ---------------------------------------------------------------------------
# Helpers
# ---------------------------------------------------------------------------
sub _two_db_join {
my (%opts) = @_;
t/data-flow.t view on Meta::CPAN
# Without join_map or filters, AUTOLOAD must still resolve $db and delegate.
# Since DFMinimalDA does not implement AUTOLOAD itself, any column shortcut
# call would fail if the direct-delegation path were broken.
# We verify by using a custom DA that DOES define the column as a method.
{
package DirectDA;
use parent -norequire, 'Database::Abstraction';
sub new { bless { id=>'entry', _cols=>['entry','tag'], _rows=>[], _schema=>{}, _ts=>1 }, shift }
sub columns { return $_[0]->{_cols} }
sub schema { return {} }
sub updated { return 1 }
sub set_logger { $_[0]->{logger} = $_[1]; return $_[0] }
sub selectall_arrayref { return $_[0]->{_rows} }
sub tag { return 'direct-value' } # method that AUTOLOAD will delegate to
sub DESTROY {}
}
my $da = DirectDA->new();
my $j = Database::Join->new(databases => [$da], join_column => 'entry');
# No join_map or filters: AUTOLOAD takes the direct path and calls $da->tag()
my $val = $j->tag();
is $val, 'direct-value',
cols => $args{cols} // ['entry'],
rows => $args{rows} // [],
id => $args{id} // 'entry',
updated => $args{updated} // $UPDATED,
schema => $args{schema} // {},
}, $class;
}
sub columns { return $_[0]->{cols} }
sub schema { return $_[0]->{schema} }
sub updated { return $_[0]->{updated} }
sub selectall_arrayref {
my ($self, $criteria) = @_;
$criteria //= {};
my @results;
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}) {
t/edge_cases.t view on Meta::CPAN
_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') {
t/edge_cases.t view on Meta::CPAN
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};
t/function.t view on Meta::CPAN
id => $args{id} // 'entry',
_cols => $args{cols} // ['entry'],
_rows => $args{rows} // [],
_schema => $args{schema} // {},
_ts => $args{updated} // 1,
}, $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) = @_;
my @rows = @{ $self->{_rows} };
# Simple equality filter for tests that need it
for my $col (keys %{ $criteria // {} }) {
my $val = $criteria->{$col};
next if ref $val;
@rows = grep { defined $_->{$col} && $_->{$col} eq $val } @rows;
}
t/integration.t view on Meta::CPAN
id => $args{id} // 'entry',
_cols => $args{cols} // ['entry'],
_rows => $args{rows} // [],
_schema => $args{schema} // {},
_ts => $args{updated} // 1_000_000,
}, $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) = @_;
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};
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};
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;
}
t/transaction.t view on Meta::CPAN
schema => $args{schema} // {},
updated => $args{updated} // 1,
_fail => $args{fail} // 0,
_calls => 0,
_logger => undef,
}, $class;
}
sub columns { return $_[0]->{cols} }
sub schema { return $_[0]->{schema} }
sub updated { return $_[0]->{updated} }
sub set_logger { $_[0]->{_logger} = $_[1]; return $_[0] }
sub get_logger { return $_[0]->{_logger} }
sub call_count { return $_[0]->{_calls} }
sub set_fail { $_[0]->{_fail} = $_[1]; return $_[0] }
sub reset_calls { $_[0]->{_calls} = 0; return $_[0] }
sub selectall_arrayref {
my ($self, $criteria) = @_;
$self->{_calls}++;
croak 'TransactionDA: simulated mid-flight failure' if $self->{_fail};
id => $args{id} // 'entry',
_cols => $args{cols} // ['entry'],
_rows => $args{rows} // [],
_schema => $args{schema} // {},
_ts => $args{updated} // 1,
}, $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) = @_;
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 }
( run in 4.768 seconds using v1.01-cache-2.11-cpan-6736b670a1e )