File Coverage

blib/lib/DBIx/Class/Helper/Row/OnColumnChange.pm
Criterion Covered Total %
statement 92 92 100.0
branch 29 36 80.5
condition n/a
subroutine 15 15 100.0
pod 5 5 100.0
total 141 148 95.2


line stmt bran cond sub pod time code
1             package DBIx::Class::Helper::Row::OnColumnChange;
2             $DBIx::Class::Helper::Row::OnColumnChange::VERSION = '2.036000';
3             # ABSTRACT: Do things when the values of a column change
4              
5 56     56   27429 use strict;
  56         129  
  56         1608  
6 56     56   307 use warnings;
  56         139  
  56         1600  
7              
8 56     56   275 use parent 'DBIx::Class::Helper::Row::StorageValues', 'DBIx::Class::Row';
  56         114  
  56         272  
9              
10 56     56   3049 use List::Util 'first';
  56         125  
  56         3165  
11 56     56   328 use DBIx::Class::Candy::Exports;
  56         106  
  56         346  
12 56     56   20607 use namespace::clean;
  56         150  
  56         326  
13              
14             export_methods [qw(before_column_change around_column_change after_column_change)];
15              
16             __PACKAGE__->mk_group_accessors(inherited => $_)
17             for qw(_before_change _around_change _after_change);
18              
19             sub before_column_change {
20 57 50   57 1 17814 die 'Invalid number of arguments. One $column => $args pair at a time.'
21             unless @_ == 3;
22              
23 57         170 my $self = shift;
24              
25 57         149 my $column = shift;
26 57         142 my $args = shift;
27              
28 57 50       234 die 'method is a required parameter' unless $args->{method};
29 57         171 $args->{column} = $column;
30 57         198 $args->{txn_wrap} = !!$args->{txn_wrap};
31              
32 57 100       1749 $self->_before_change([]) unless $self->_before_change;
33 57         11493 push @{$self->_before_change}, $args;
  57         1020  
34             }
35              
36             sub around_column_change {
37 1 50   1 1 35 die 'Invalid number of arguments. One $column => $args pair at a time.'
38             unless @_ == 3;
39              
40 1         4 my $self = shift;
41              
42 1         3 my $column = shift;
43 1         3 my $args = shift;
44              
45 1 50       5 die 'no method passed!' unless $args->{method};
46 1         4 $args->{column} = $column;
47 1         4 $args->{txn_wrap} = !!$args->{txn_wrap};
48              
49 1 50       27 $self->_around_change([]) unless $self->_around_change;
50 1         210 push @{$self->_around_change}, $args;
  1         19  
51             }
52              
53             sub after_column_change {
54 4 100   4 1 10886 die 'Invalid number of arguments. One $column => $args pair at a time.'
55             unless @_ == 3;
56              
57 3         9 my $self = shift;
58              
59 3         6 my $column = shift;
60 3         5 my $args = shift;
61              
62 3 50       10 die 'no method passed!' unless $args->{method};
63 3         9 $args->{column} = $column;
64 3         10 $args->{txn_wrap} = !!$args->{txn_wrap};
65              
66 3 100       102 $self->_after_change([]) unless $self->_after_change;
67 3         590 unshift @{$self->_after_change}, $args;
  3         64  
68             }
69              
70             sub update {
71 7     7 1 22485 my ($self, $args) = @_;
72              
73 7 100       87 $self->set_inflated_columns($args) if $args;
74              
75 7 50       1034 my %dirty = $self->get_dirty_columns
76             or return $self;
77              
78 7 100       102 my @all_before = @{$self->_before_change || []};
  7         187  
79 7 100       455 my @all_around = @{$self->_around_change || []};
  7         154  
80 7 100       555 my @all_after = @{$self->_after_change || []};
  7         147  
81              
82             # prepare functions
83 7         438 my @before = grep { defined $dirty{$_->{column}} } @all_before;
  7         29  
84 7         17 my @around = grep { defined $dirty{$_->{column}} } @all_around;
  4         13  
85 7         18 my @after = grep { defined $dirty{$_->{column}} } @all_after;
  10         26  
86              
87 7         101 my $inner = $self->next::can;
88              
89             my $final = $self->on_column_change_allow_override_args
90 1     1   5 ? sub { $self->$inner }
91 7 100   6   179 : sub { $self->$inner($args) };
  6         739  
92              
93 7         753 for ( reverse @around ) {
94 2         5 my $fn = $_->{method};
95 2         11 my $old = $self->get_storage_value($_->{column});
96 2         31 my $new = $dirty{$_->{column}};
97 2         4 my $old_final = $final;
98 2     2   11 $final = sub { $self->$fn($old_final, $old, $new) };
  2         7  
99             }
100              
101             # do we wrap it in a transaction?
102 20 100   20   66 my $txn_wrap = first { defined $dirty{$_->{column}} && $_->{txn_wrap} }
103 7         37 @all_before, @all_around, @all_after;
104              
105 7         23 my $guard;
106 7 100       27 $guard = $self->result_source->schema->txn_scope_guard if $txn_wrap;
107              
108 7         1381 for (@before) {
109 5         12 my $fn = $_->{method};
110 5         21 my $old = $self->get_storage_value($_->{column});
111 5         74 my $new = $dirty{$_->{column}};
112 5         22 $self->$fn($old, $new);
113             }
114              
115 7         236 my $ret = $final->();
116              
117 7         33 for (@after) {
118 5         696 my $fn = $_->{method};
119 5         30 my $old = $self->get_storage_value($_->{column});
120 5         67 my $new = $dirty{$_->{column}};
121 5         19 $self->$fn($old, $new);
122             }
123              
124 5 100       30 $guard->commit if $txn_wrap;
125              
126 5         99 $ret
127             }
128              
129 2     2 1 10 sub on_column_change_allow_override_args { 0 }
130              
131             1;
132              
133             __END__
134              
135             =pod
136              
137             =head1 NAME
138              
139             DBIx::Class::Helper::Row::OnColumnChange - Do things when the values of a column change
140              
141             =head1 SYNOPSIS
142              
143             package MyApp::Schema::Result::Account;
144              
145             use parent 'DBIx::Class::Core';
146              
147             __PACKAGE__->load_components(qw(Helper::Row::OnColumnChange));
148              
149             __PACKAGE__->table('Account');
150              
151             __PACKAGE__->add_columns(
152             id => {
153             data_type => 'integer',
154             is_auto_increment => 1,
155             },
156             amount => {
157             data_type => 'float',
158             keep_storage_value => 1,
159             },
160             );
161             sub on_column_change_allow_override_args { 1 }
162              
163             __PACKAGE__->before_column_change(
164             amount => {
165             method => 'bank_transfer',
166             txn_wrap => 1,
167             }
168             );
169              
170             sub bank_transfer {
171             my ($self, $old_value, $new_value) = @_;
172              
173             my $delta = abs($old_value - $new_value);
174             if ($old_value < $new_value) {
175             Bank->subtract($delta)
176             } else {
177             Bank->add($delta)
178             }
179             }
180              
181             1;
182              
183             or with L<DBIx::Class::Candy>:
184              
185             package MyApp::Schema::Result::Account;
186              
187             use DBIx::Class::Candy -components => ['Helper::Row::OnColumnChange'];
188              
189             table 'Account';
190              
191             column id => {
192             data_type => 'integer',
193             is_auto_increment => 1,
194             };
195              
196             column amount => {
197             data_type => 'float',
198             keep_storage_value => 1,
199             };
200             sub on_column_change_allow_override_args { 1 }
201              
202             before_column_change amount => {
203             method => 'bank_transfer',
204             txn_wrap => 1,
205             };
206              
207             sub bank_transfer {
208             my ($self, $old_value, $new_value) = @_;
209              
210             my $delta = abs($old_value - $new_value);
211             if ($old_value < $new_value) {
212             Bank->subtract($delta)
213             } else {
214             Bank->add($delta)
215             }
216             }
217              
218             1;
219              
220             =head1 DESCRIPTION
221              
222             This module codifies a pattern that I've used in a number of projects, namely
223             that of doing B<something> when a column changes it's value in the database.
224             It leverages L<DBIx::Class::Helper::Row::StorageValues> for passing in the
225             C<$old_value>, which do not have to use. If you leave the
226             C<keep_storage_value> out of the column definition it will just pass C<undef>
227             in as the $old_value. Also note the C<txn_wrap> option. This allows you to
228             specify that you want the call to C<update> and the call to the method you
229             requested to be wrapped in a transaction. If you end up calling more than
230             one method due to multiple column change methods and more than one specify
231             C<txn_wrap> it will still only wrap once.
232              
233             I've gone to great lengths to ensure that order is preserved, so C<before>
234             and C<around> changes are called in order of definition and C<after> changes
235             are called in reverse order.
236              
237             To be clear, the change methods only get called if the value will be changed
238             after C<update> runs. It correctly looks at the current value of the column
239             as well as the arguments passed to C<update>.
240              
241             =head1 CANDY EXPORTS
242              
243             If used in conjunction with L<DBIx::Class::Candy> this component will export:
244              
245             =over
246              
247             =item before_column_change
248              
249             =item around_column_change
250              
251             =item after_column_change
252              
253             =back
254              
255             =head1 NO SURPRISE RACE CONDITIONS
256              
257             One thing that should be made totally clear is that the column change callbacks
258             are in effect B<< only once >> in a given update. If you expect to be able to
259             do something weird like calling one of the callbacks which changes a value with
260             an accessor which calls a callback etc etc, you probably just need to write some
261             code to do that yourself. This helper is specifically made with the aim of
262             reacting to changes immediately before they hit the database.
263              
264             =head1 METHODS
265              
266             =head2 before_column_change
267              
268             __PACKAGE__->before_column_change(
269             col_name => {
270             method => 'method', # <-- anything that can be called as a method
271             txn_wrap => 1, # <-- true if you want it to be wrapped in a txn
272             }
273             );
274              
275             Note: the arguments passed to C<method> will be
276             C<< $self, $old_value, $new_value >>.
277              
278             =head2 after_column_change
279              
280             __PACKAGE__->after_column_change(
281             col_name => {
282             method => 'method', # <-- anything that can be called as a method
283             txn_wrap => 1, # <-- true if you want it to be wrapped in a txn
284             }
285             );
286              
287             Note: the arguments passed to C<method> will be
288             C<< $self, $new_value, $new_value >>. (Because the old value has been changed.)
289              
290             =head2 around_column_change
291              
292             __PACKAGE__->around_column_change(
293             col_name => {
294             method => 'method', # <-- anything that can be called as a method
295             txn_wrap => 1, # <-- true if you want it to be wrapped in a txn
296             }
297             );
298              
299             Note: the arguments passed to C<method> will be
300             C<< $self, $next, $old_value, $new_value >>.
301              
302             Around is subtly different than the other two callbacks. You B<must> call
303             C<$next> in your method or it will not work at all. A silly example of how
304             this is done could be:
305              
306             sub around_change_name {
307             my ($self, $next, $old, $new) = @_;
308              
309             my $govt_records = $self->govt_records;
310              
311             $next->();
312              
313             $govt_records->update({ name => $new });
314             }
315              
316             Note: the above code implies a weird database schema. I haven't actually seen
317             a time when I've needed around yet, but it seems like there is a use-case.
318              
319             Also Note: you don't get to change the args to C<$next>. If you think you
320             should be able to, you probably don't understand what this component is for.
321             That or you know something I don't (equally likely.)
322              
323             =head2 on_column_change_allow_override_args
324              
325             This is a method that allows a user to circumvent a strange bug in the initial
326             implementation. Basically, if the user wanted, she could use
327             L</before_column_change> to override the value of a given column before
328             C<update> gets called, thus replacing the value. Unfortunately this worked in
329             the case of accessors setting the value, but not if the user had used an
330             argument to C<update>. To be clear, if you want the following to actually
331             replace the value:
332              
333             __PACKAGE__->before_column_change(
334             name => {
335             method => sub {
336             my ($self, $old, $new) = @_;
337              
338             $self->name(uc $new);
339             },
340             },
341             );
342              
343             you will need to define this in your result class:
344              
345             sub on_column_change_allow_override_args { 1 }
346              
347             If for some reason you need the old style, a default of false is already set.
348             If you are painted in the corner and need both, you can create an accessor and
349             set it yourself to change the behavior:
350              
351             __PACKAGE__->mk_group_accessors(inherited => 'on_column_change_allow_override_args');
352             ...
353             $obj->on_column_change_allow_override_args(1); # works the new way
354              
355             =head1 AUTHOR
356              
357             Arthur Axel "fREW" Schmidt <frioux+cpan@gmail.com>
358              
359             =head1 COPYRIGHT AND LICENSE
360              
361             This software is copyright (c) 2020 by Arthur Axel "fREW" Schmidt.
362              
363             This is free software; you can redistribute it and/or modify it under
364             the same terms as the Perl 5 programming language system itself.
365              
366             =cut