package DBIx::Class::Helper::Row::OnColumnChange;
{
$DBIx::Class::Helper::Row::OnColumnChange::VERSION = '2.016001';
}
use strict;
use warnings;
# ABSTRACT: Do things when the values of a column change
use parent 'DBIx::Class::Helper::Row::StorageValues';
use List::Util 'first';
use DBIx::Class::Candy::Exports;
use namespace::clean;
export_methods [qw(before_column_change around_column_change after_column_change)];
__PACKAGE__->mk_group_accessors(inherited => $_)
for qw(_before_change _around_change _after_change);
sub before_column_change {
die 'Invalid number of arguments. One $column => $args pair at a time.'
unless @_ == 3;
my $self = shift;
my $column = shift;
my $args = shift;
die 'method is a required parameter' unless $args->{method};
$args->{column} = $column;
$args->{txn_wrap} = !!$args->{txn_wrap};
$self->_before_change([]) unless $self->_before_change;
push @{$self->_before_change}, $args;
}
sub around_column_change {
die 'Invalid number of arguments. One $column => $args pair at a time.'
unless @_ == 3;
my $self = shift;
my $column = shift;
my $args = shift;
die 'no method passed!' unless $args->{method};
$args->{column} = $column;
$args->{txn_wrap} = !!$args->{txn_wrap};
$self->_around_change([]) unless $self->_around_change;
push @{$self->_around_change}, $args;
}
sub after_column_change {
die 'Invalid number of arguments. One $column => $args pair at a time.'
unless @_ == 3;
my $self = shift;
my $column = shift;
my $args = shift;
die 'no method passed!' unless $args->{method};
$args->{column} = $column;
$args->{txn_wrap} = !!$args->{txn_wrap};
$self->_after_change([]) unless $self->_after_change;
unshift @{$self->_after_change}, $args;
}
sub update {
my ($self, $args) = @_;
$self->set_inflated_columns($args) if $args;
my %dirty = $self->get_dirty_columns
or return $self;
my @all_before = @{$self->_before_change || []};
my @all_around = @{$self->_around_change || []};
my @all_after = @{$self->_after_change || []};
# prepare functions
my @before = grep { defined $dirty{$_->{column}} } @all_before;
my @around = grep { defined $dirty{$_->{column}} } @all_around;
my @after = grep { defined $dirty{$_->{column}} } @all_after;
my $inner = $self->next::can;
my $final = sub { $self->$inner($args) };
for ( reverse @around ) {
my $fn = $_->{method};
my $old = $self->get_storage_value($_->{column});
my $new = $dirty{$_->{column}};
my $old_final = $final;
$final = sub { $self->$fn($old_final, $old, $new) };
}
# do we wrap it in a transaction?
my $txn_wrap = first { defined $dirty{$_->{column}} && $_->{txn_wrap} }
@all_before, @all_around, @all_after;
my $guard;
$guard = $self->result_source->schema->txn_scope_guard if $txn_wrap;
for (@before) {
my $fn = $_->{method};
my $old = $self->get_storage_value($_->{column});
my $new = $dirty{$_->{column}};
$self->$fn($old, $new);
}
my $ret = $final->();
for (@after) {
my $fn = $_->{method};
my $old = $self->get_storage_value($_->{column});
my $new = $dirty{$_->{column}};
$self->$fn($old, $new);
}
$guard->commit if $txn_wrap;
$ret
}
1;
__END__
=pod
=head1 NAME
DBIx::Class::Helper::Row::OnColumnChange - Do things when the values of a column change
=head1 VERSION
version 2.016001
=head1 SYNOPSIS
package MyApp::Schema::Result::Account;
use parent 'DBIx::Class::Core';
__PACKAGE__->load_components(qw(Helper::Row::OnColumnChange));
__PACKAGE__->table('Account');
__PACKAGE__->add_columns(
id => {
data_type => 'integer',
is_auto_increment => 1,
},
amount => {
data_type => 'float',
keep_storage_value => 1,
},
);
__PACKAGE__->before_column_change(
amount => {
method => 'bank_transfer',
txn_wrap => 1,
}
);
sub bank_transfer {
my ($self, $old_value, $new_value) = @_;
my $delta = abs($old_value - $new_value);
if ($old_value < $new_value) {
Bank->subtract($delta)
} else {
Bank->add($delta)
}
}
1;
or with L<DBIx::Class::Candy>:
package MyApp::Schema::Result::Account;
use DBIx::Class::Candy -components => ['Helper::Row::OnColumnChange'];
table 'Account';
column id => {
data_type => 'integer',
is_auto_increment => 1,
};
column amount => {
data_type => 'float',
keep_storage_value => 1,
};
before_column_change amount => {
method => 'bank_transfer',
txn_wrap => 1,
};
sub bank_transfer {
my ($self, $old_value, $new_value) = @_;
my $delta = abs($old_value - $new_value);
if ($old_value < $new_value) {
Bank->subtract($delta)
} else {
Bank->add($delta)
}
}
1;
=head1 DESCRIPTION
This module codifies a pattern that I've used in a number of projects, namely
that of doing B<something> when a column changes it's value in the database.
It leverages L<DBIx::Class::Helper::Row::StorageValues> for passing in the
C<$old_value>, which do not have to use. If you leave the
C<keep_storage_value> out of the column definition it will just pass C<undef>
in as the $old_value. Also note the C<txn_wrap> option. This allows you to
specify that you want the call to C<update> and the call to the method you
requested to be wrapped in a transaction. If you end up calling more than
one method due to multple column change methods and more than one specify
C<txn_wrap> it will still only wrap once.
I've gone to great lengths to ensure that order is preserved, so C<before>
and C<around> changes are called in order of definition and C<after> changes
are called in reverse order.
To be clear, the change methods only get called if the value will be changed
after C<update> runs. It correctly looks at the current value of the column
as well as the arguments passed to C<update>.
=head1 METHODS
=head2 before_column_change
__PACKAGE__->before_column_change(
col_name => {
method => 'method', # <-- anything that can be called as a method
txn_wrap => 1, # <-- true if you want it to be wrapped in a txn
}
);
Note: the arguments passed to C<method> will be
C<< $self, $old_value, $new_value >>.
=head2 after_column_change
__PACKAGE__->after_column_change(
col_name => {
method => 'method', # <-- anything that can be called as a method
txn_wrap => 1, # <-- true if you want it to be wrapped in a txn
}
);
Note: the arguments passed to C<method> will be
C<< $self, $old_value, $new_value >>.
=head2 around_column_change
__PACKAGE__->around_column_change(
col_name => {
method => 'method', # <-- anything that can be called as a method
txn_wrap => 1, # <-- true if you want it to be wrapped in a txn
}
);
Note: the arguments passed to C<method> will be
C<< $self, $next, $old_value, $new_value >>.
Around is subtly different than the other two callbacks. You B<must> call
C<$next> in your method or it will not work at all. A silly example of how
this is done could be:
sub around_change_name {
my ($self, $next, $old, $new) = @_;
my $govt_records = $self->govt_records;
$next->();
$govt_records->update({ name => $new });
}
Note: the above code implies a weird database schema. I haven't actually seen
a time when I've needed around yet, but it seems like there is a use-case.
Also Note: you don't get to change the args to C<$next>. If you think you
should be able to, you probably don't understand what this component is for.
That or you know something I don't (equally likely.)
=head1 CANDY EXPORTS
If used in conjunction with L<DBIx::Class::Candy> this component will export:
=over
=item before_column_change
=item around_column_change
=item after_column_change
=back
=head1 AUTHOR
Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2012 by Arthur Axel "fREW" Schmidt.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut