File Coverage

blib/lib/DBIx/Class/AuditAny/Role/Storage.pm
Criterion Covered Total %
statement 124 132 93.9
branch 25 32 78.1
condition 11 20 55.0
subroutine 20 22 90.9
pod 4 4 100.0
total 184 210 87.6


line stmt bran cond sub pod time code
1             package DBIx::Class::AuditAny::Role::Storage;
2 13     13   47 use strict;
  13         16  
  13         332  
3 13     13   48 use warnings;
  13         15  
  13         313  
4              
5             # ABSTRACT: Role to apply to tracked DBIx::Class::Storage objects
6              
7 13     13   46 use Moo::Role;
  13         12  
  13         66  
8 13     13   15155 use MooX::Types::MooseLike::Base qw(:all);
  13         16  
  13         3436  
9              
10             ## TODO:
11             ## 1. track rekey in update
12             ## 2. track changes in FK with cascade
13              
14              
15             =head1 NAME
16              
17             DBIx::Class::AuditAny::Role::Storage - Role to apply to tracked DBIx::Class::Storage objects
18              
19             =head1 DESCRIPTION
20              
21             This role adds the hooks to the DBIC Storage object to be able to sniff and collect change data
22             has it happens in real time.
23              
24             =cut
25              
26 13     13   65 use strict;
  13         15  
  13         201  
27 13     13   38 use warnings;
  13         13  
  13         292  
28 13     13   54 use Try::Tiny;
  13         16  
  13         556  
29 13     13   50 use DBIx::Class::AuditAny::Util;
  13         12  
  13         867  
30 13     13   53 use Term::ANSIColor qw(:constants);
  13         18  
  13         28340  
31              
32              
33             =head1 REQUIRES
34              
35             =head2 txn_do
36              
37             =head2 insert
38              
39             =head2 update
40              
41             =head2 delete
42              
43             =head2 insert_bulk
44              
45             =cut
46             requires 'txn_do';
47             requires 'insert';
48             requires 'update';
49             requires 'delete';
50             requires 'insert_bulk';
51              
52             =head1 ATTRIBUTES
53              
54             head2 auditors
55              
56             List of Auditor objects which we are collecting data for. Typically there will be only one
57             Auditor, but there can be many, allowing for data to be logged to a file by one, logged in
58             a database by another, and then some other random watcher which takes some action when a
59             certain event is detected. All of these can run simultaneously, and receive the sniffed data
60             which we will collect only once.
61             =cut
62             has 'auditors', is => 'ro', lazy => 1, default => sub {[]};
63              
64              
65             =head1 METHODS
66              
67             =head2 all_auditors
68              
69             Returns a list of all configured Auditor objects
70             =cut
71 272     272 1 292 sub all_auditors { @{(shift)->auditors} }
  272         4419  
72              
73             =head2 auditor_count
74              
75             The number of configured auditors
76             =cut
77 14     14 1 340 sub auditor_count { scalar (shift)->all_auditors }
78              
79             =head2 add_auditor
80              
81             Adds a new Auditor object(s) to report to
82             =cut
83 14     14 1 145 sub add_auditor { push @{(shift)->auditors},(shift) }
  14         195  
84              
85              
86             before 'txn_begin' => sub {
87             my $self = shift;
88             return if ($ENV{DBIX_CLASS_AUDITANY_SKIP});
89             $_->start_unless_changeset for ($self->all_auditors);
90             };
91              
92             # txn_commit
93             # Note that we're hooking into -before- txn_commit rather than
94             # -after- which would conceptually make better sense. The reason
95             # is that we provide for the ability for collectors that store
96             # their change data within the same schema being tracked, which
97             # means the stored data will end up being a part of the same
98             # transaction, thus hooking into after on the outermost commit
99             # could cause deep recursion.
100             # TODO/FIXME: What about collectors that
101             # *don't* do this, and an exception occurring within that final
102             # commit??? It could possibly lead to recording a change that
103             # didn't actually happen (i.e. was rolled back). I think the way
104             # to handle this is for the collector to declare if it is storing
105             # to the tracked schema or not, and handle each case differently
106             before 'txn_commit' => sub {
107             my $self = shift;
108            
109             # Only finish in the outermost transaction
110             if($self->transaction_depth == 1) {
111             $_->finish_if_changeset for ($self->all_auditors);
112             }
113             };
114              
115             around 'txn_rollback' => sub {
116             my ($orig, $self, @args) = @_;
117            
118             my @ret;
119             my $want = wantarray;
120             try {
121             #############################################################
122             # --- Call original - scalar/list/void context agnostic ---
123             @ret = !defined $want ? do { $self->$orig(@args); undef }
124             : $want ? $self->$orig(@args)
125             : scalar $self->$orig(@args);
126             # ---
127             #############################################################
128             }
129             catch {
130             my $err = shift;
131             $_->_exception_cleanup($err) for ($self->all_auditors);
132             die $err;
133             };
134            
135             # Should never get here because txn_rollback throws an exception
136             # per-design. But, we still handle the case for good measure:
137             $_->_exception_cleanup('txn_rollback') for ($self->all_auditors);
138            
139             return $want ? @ret : $ret[0];
140             };
141              
142              
143             # insert is the most simple. Always applies to exactly 1 row:
144             around 'insert' => sub {
145             my ($orig, $self, @args) = @_;
146             return $self->$orig(@args) if ($ENV{DBIX_CLASS_AUDITANY_SKIP});
147            
148             my ($Source, $to_insert) = @args;
149            
150             # Start new insert operation within each Auditor and get back
151             # all the created ChangeContexts from all auditors. The auditors
152             # will keep track of their own changes temporarily in a "group":
153             my @ChangeContexts = map {
154             $_->_start_current_change_group($Source, 0,'insert',{
155             to_columns => $to_insert
156             })
157             } $self->all_auditors;
158            
159             my @ret;
160             my $want = wantarray;
161             try {
162             #############################################################
163             # --- Call original - scalar/list/void context agnostic ---
164             @ret = !defined $want ? do { $self->$orig(@args); undef }
165             : $want ? $self->$orig(@args)
166             : scalar $self->$orig(@args);
167             # ---
168             #############################################################
169             }
170             catch {
171             my $err = shift;
172             $_->_exception_cleanup($err) for ($self->all_auditors);
173             die $err;
174             };
175            
176             # Update each ChangeContext with the result data:
177             $_->record($ret[0]) for (@ChangeContexts);
178            
179             # Tell each auditor that we're done and to record the change group
180             # into the active changeset:
181             $_->_finish_current_change_group for ($self->all_auditors);
182            
183             return $want ? @ret : $ret[0];
184             };
185              
186              
187             ### TODO: ###
188             # insert_bulk is a tricky case. It exists for the purpose of performance,
189             # and skips reading back in the inserted row(s). BUT, we need to read back
190             # in the inserted row, and we have no safe way of doing that with a bulk
191             # insert (auto-generated auto-inc keys, etc). DBIC was already designed with
192             # with this understanding, and so insert_bulk is already only called when
193             # no result is needed/expected back: DBIx::Class::ResultSet->populate() called
194             # in *void* context.
195             #
196             # Based on this fact, I think that the only rational way to be able to
197             # Audit the inserted rows is to override and convert any calls to insert_bulk()
198             # into calls to regular calls to insert(). Interfering with the original
199             # flow/operation is certainly not ideal, but I don't see any alternative.
200             around 'insert_bulk' => sub {
201             my ($orig, $self, @args) = @_;
202             return $self->$orig(@args) if ($ENV{DBIX_CLASS_AUDITANY_SKIP});
203            
204             my ($Source, $cols, $data) = @args;
205            
206             #
207             # TODO ....
208             #
209            
210             my @ret;
211             my $want = wantarray;
212             try {
213             #############################################################
214             # --- Call original - scalar/list/void context agnostic ---
215             @ret = !defined $want ? do { $self->$orig(@args); undef }
216             : $want ? $self->$orig(@args)
217             : scalar $self->$orig(@args);
218             # ---
219             #############################################################
220             }
221             catch {
222             my $err = shift;
223             $_->_exception_cleanup($err) for ($self->all_auditors);
224             die $err;
225             };
226              
227             return $want ? @ret : $ret[0];
228             };
229              
230              
231             has '_change_contexts', is => 'rw', isa => ArrayRef[Object], lazy => 1, default => sub {[]};
232 18     18   30 sub _add_change_contexts { push @{shift->_change_contexts},@_ }
  18         268  
233              
234             sub _follow_row_changes($$) {
235 18     18   725 my $self = shift;
236 18         27 my $cnf = shift;
237            
238 18         34 my $Source = $cnf->{Source};
239 18         35 my $change = $cnf->{change};
240 18         29 my $cond = $cnf->{cond};
241 18         28 my $action = $cnf->{action};
242            
243 18         29 my $orig = $cnf->{method};
244 18   100     128 my $args = $cnf->{args} || [];
245 18   33     115 my $want = $cnf->{want} || wantarray;
246 18         30 my $rows = $cnf->{rows};
247 18   100     99 my $nested = $cnf->{nested} || 0;
248            
249 18         69 my $source_name = $Source->source_name;
250            
251 18 100       313 $self->_change_contexts([]) unless ($nested);
252            
253             # Get the current rows if they haven't been supplied and a
254             # condition has been supplied ($cond):
255 18 100 66     782 $rows = get_raw_source_rows($Source,$cond)
256             if (!defined $rows && defined $cond);
257              
258 18         777 my @change_datam = map {{
259 28         115 old_columns => $_,
260             to_columns => $change,
261             condition => $cond
262             }} @$rows;
263            
264            
265             # Start new change operation within each Auditor and store the
266             # created ChangeContexts (from all auditors) in the _change_contexts.
267             # attribute to be updated and recorded at the end of the update. The
268             # auditors will keep track of their own changes temporarily in a "group":
269             $self->_add_change_contexts(
270             map {
271 18         70 $_->_start_current_change_group($Source, $nested, $action, @change_datam)
  18         205  
272             } $self->all_auditors
273             );
274            
275             # -----
276             # Recursively follow effective changes in other tables that will
277             # be caused by any db-side cascades defined in relationships:
278 18         185 $self->_follow_relationship_cascades($Source,$cond,$change);
279             # -----
280            
281             # Run the original/supplied method:
282 18         20 my @ret;
283 18 100       52 if($orig) {
284             try {
285             #############################################################
286             # --- Call original - scalar/list/void context agnostic ---
287 11 50   11   642 @ret = !defined $want ? do { $self->$orig(@$args); undef }
  0 50       0  
  0         0  
288             : $want ? $self->$orig(@$args)
289             : scalar $self->$orig(@$args);
290             # ---
291             #############################################################
292             }
293             catch {
294 0     0   0 my $err = shift;
295 0         0 $_->_exception_cleanup($err) for ($self->all_auditors);
296 0         0 die $err;
297 11         105 };
298             }
299            
300             # Tell each auditor that we're done and to record the change group
301             # into the active changeset (unless the action we're following is nested):
302 18 100       54585 unless ($nested) {
303 11         96 $self->_record_change_contexts;
304 11         688 $_->_finish_current_change_group for ($self->all_auditors);
305             }
306            
307 18 50       920 return $want ? @ret : $ret[0];
308             }
309              
310              
311             sub _follow_relationship_cascades {
312 18     18   28 my ($self, $Source, $cond, $change) = @_;
313            
314             ## IN PROGRESS.....
315            
316             # If any of these columns are being changed, we have to also watch the
317             # corresponding relationhips for changes (from cascades) during the
318             # course of the current database operation. This can be expensive, but
319             # we prefer accuracy over speed
320 18         81 my $cascade_cols = $self->_get_cascading_rekey_columns($Source);
321            
322             # temp: just get all of themfor now
323             # this should be limited to only rels associated with columns
324             # being changed
325 18         74 my @rels = uniq(map { @{$cascade_cols->{$_}} } keys %$cascade_cols);
  8         8  
  8         34  
326            
327 18         50 foreach my $rel (@rels) {
328 11         26 my $rinfo = $Source->relationship_info($rel);
329             #my $rrinfo = $Source->reverse_relationship_info($rel);
330            
331             # Generate a virtual 'change' to describe what will happen in the related table
332 11         43 my $map = &_cond_foreign_keymap($rinfo->{cond});
333 11         14 my $rel_change = {};
334 11         21 foreach my $col (keys %$change) {
335 11 100       26 my $fcol = $map->{$col} or next;
336 8         17 $rel_change->{$fcol} = $change->{$col};
337             }
338            
339             # Only track related rows if there is at least one related change:
340 11 100       36 if(scalar(keys %$rel_change) > 0) {
341             # Get related rows that will be changed from the cascade:
342 8         26 my $rel_rows = get_raw_source_related_rows($Source,$rel,$cond);
343            
344             # Follow these rows via special nested call:
345 8 100       681 $self->_follow_row_changes({
346             Source => $Source->related_source($rel),
347             rows => $rel_rows,
348             cond => {},
349             nested => 1,
350             action => 'update',
351             change => $rel_change
352             }) if(scalar @$rel_rows > 0);
353             }
354             }
355             }
356              
357              
358             # Builds a map that can be used to convert column names into
359             # their fk name on the other side of a relationship
360             sub _cond_foreign_keymap {
361 11     11   16 my $cond = shift;
362 11         12 my $alias = shift;
363            
364 11         13 my $map = {};
365            
366             # TODO: doesn't support all valid conditions, but *DOES*
367             # support those that can express a valid db-side CASCADE,
368             # which is what this is for:
369 11         22 foreach my $k (keys %$cond) {
370 13         26 my @f = ($k,$cond->{$k});
371 13         9 my $d = {};
372 13         20 $d->{$_->[0]} = $_->[1] for (map {[split(/\./,$_,2)]} @f);
  26         103  
373            
374             die "error parsing condition"
375 13 50 33     54 unless (exists $d->{foreign} && exists $d->{self});
376            
377 13         30 $map->{$d->{self}} = $d->{foreign};
378             }
379 11         18 return $map;
380             }
381              
382              
383              
384             sub _record_change_contexts {
385 11     11   25 my $self = shift;
386            
387             # Fetch the new values for -each- row, independently.
388             # Build a condition specific to this row and fetch it,
389             # taking into account the change that was just made, and
390             # then record the new columns in the ChangeContext:
391 11         18 foreach my $ChangeContext (@{$self->_change_contexts}) {
  11         341  
392 28         747 my $Source = $ChangeContext->SourceContext->ResultSource;
393             # Get the primry keys, or all columns if there are none:
394 28         113 my @pri_cols = $Source->primary_columns;
395 28 50       218 @pri_cols = $Source->columns unless (scalar @pri_cols > 0);
396            
397 28         450 my $change = $ChangeContext->to_columns;
398 28         541 my $old = $ChangeContext->old_columns;
399            
400             # TODO: cache the new columns to prevent duplicate fetches for multiple auditors
401             my $new_rows = get_raw_source_rows($Source,{ map {
402 28 100       166 $_ => (exists $change->{$_} ? $change->{$_} : $old->{$_})
  28         208  
403             } @pri_cols });
404            
405             # TODO/FIXME: How should we handle it if we got back
406             # something other than exactly one row here?
407 28 50       1600 die "Unexpected error while trying to read updated row"
408             unless (scalar @$new_rows == 1);
409            
410 28         45 my $new = pop @$new_rows;
411 28         110 $ChangeContext->record($new);
412             }
413            
414             # Clear:
415 11         547 $self->_change_contexts([]);
416             }
417              
418              
419             around 'update' => sub {
420             my ($orig, $self, @args) = @_;
421             return $self->$orig(@args) if ($ENV{DBIX_CLASS_AUDITANY_SKIP});
422            
423             my ($Source,$change,$cond) = @args;
424            
425             return $self->_follow_row_changes({
426             Source => $Source,
427             change => $change,
428             cond => $cond,
429             method => $orig,
430             action => 'update',
431             args => \@args,
432             want => wantarray
433             });
434             };
435              
436             around 'delete' => sub {
437             my ($orig, $self, @args) = @_;
438             return $self->$orig(@args) if ($ENV{DBIX_CLASS_AUDITANY_SKIP});
439            
440             my ($Source, $cond) = @args;
441            
442             # Get the current rows that are going to be deleted:
443             my $rows = get_raw_source_rows($Source,$cond);
444            
445             my @change_datam = map {{
446             old_columns => $_,
447             condition => $cond
448             }} @$rows;
449            
450             ###########################
451             # TODO: find cascade deletes here
452             ###########################
453            
454            
455             # Start new change operation within each Auditor and get back
456             # all the created ChangeContexts from all auditors. Each auditor
457             # will keep track of its own changes temporarily in a "group":
458             my @ChangeContexts = map {
459             $_->_start_current_change_group($Source, 0,'delete', @change_datam)
460             } $self->all_auditors;
461            
462            
463             # Do the actual deletes:
464             my @ret;
465             my $want = wantarray;
466             try {
467             #############################################################
468             # --- Call original - scalar/list/void context agnostic ---
469             @ret = !defined $want ? do { $self->$orig(@args); undef }
470             : $want ? $self->$orig(@args)
471             : scalar $self->$orig(@args);
472             # ---
473             #############################################################
474             }
475             catch {
476             my $err = shift;
477             $_->_exception_cleanup($err) for ($self->all_auditors);
478             die $err;
479             };
480            
481            
482             # TODO: should we go back to the db to make sure the rows are
483             # now gone as expected?
484            
485             $_->record for (@ChangeContexts);
486            
487             # Tell each auditor that we're done and to record the change group
488             # into the active changeset:
489             $_->_finish_current_change_group for ($self->all_auditors);
490            
491             return $want ? @ret : $ret[0];
492             };
493              
494              
495              
496             # _get_cascading_rekey_cols: gets a map of column names to relationships. These
497             # are the relationships that *could* be changed via a cascade when the column (fk)
498             # is changed.
499             # TODO: use 'cascade_rekey' attr from DBIx::Class::Shadow
500             # (DBIx::Class::Relationship::Cascade::Rekey) ?
501             sub _get_cascading_rekey_columns {
502 18     18   30 my $self = shift;
503 18         25 my $Source = shift;
504            
505             # cache for next time (should I even bother? since if rels are added to the ResultSource
506             # later this won't get updated? Is that a bigger risk than the performance boost?)
507 18   33     296 $self->_source_cascade_rekey_cols->{$Source->source_name} ||= do {
508 18         477 my $rels = { map { $_ => $Source->relationship_info($_) } $Source->relationships };
  36         205  
509            
510 18         90 my $cascade_cols = {};
511 18         60 foreach my $rel (keys %$rels) {
512             # Only multi rels apply:
513 36 100       123 next unless ($rels->{$rel}{attrs}{accessor} eq 'multi');
514            
515             # NEW: We can't currently do anything with CodeRef conditions
516 11 50 50     43 next if ((ref($rels->{$rel}{cond})||'') eq 'CODE');
517            
518             # Get all the local columns that effect (i.e. might cascade to) this relationship:
519 11         43 my @cols = $self->_parse_cond_cols_by_alias($rels->{$rel}{cond},'self');
520            
521             # Add the relationship to list for each column.
522             #$cascade_cols->{$_} ||= [] for (@cols); #<-- don't need this
523 11         21 push @{$cascade_cols->{$_}}, $rel for (@cols);
  13         32  
524             }
525            
526 18         60 return $cascade_cols;
527             };
528            
529 0         0 return $self->_source_cascade_rekey_rels->{$Source->source_name};
530             }
531              
532             has '_source_cascade_rekey_cols', is => 'ro', isa => HashRef, lazy => 1, default => sub {{}};
533              
534             sub _parse_cond_cols_by_alias {
535 11     11   14 my $self = shift;
536 11         13 my $cond = shift;
537 11         13 my $alias = shift;
538            
539             # Get the string elements (keys and values)
540             # (TODO: deep walk any hahs/array structure)
541 11         35 my @elements = %$cond;
542            
543 11   50     44 ref($_) and die "Complex conditions aren't supported yet" for (@elements);
544            
545 13         31 my @cols = map { $_->[1] } # <-- 3. just the column names
546             # 2. exclude all but the alias name we want
547 26         40 grep { $_->[0] eq $alias }
548             # 1. Convert all the element strings into alias/column pairs
549 11         16 map { [split(/\./,$_,2)] } @elements;
  26         70  
550            
551 11         32 return @cols;
552             }
553              
554              
555             =head2 changeset_do
556              
557             TODO... currently is just a wrapper around a native txn_do call. Not sure what this is meant
558             to do...
559             =cut
560             sub changeset_do {
561 0     0 1   my $self = shift;
562            
563             # TODO ...
564 0           return $self->txn_do(@_);
565             }
566              
567              
568             1;
569              
570             __END__
571              
572             =head1 SEE ALSO
573              
574             =over
575              
576             =item *
577              
578             L<DBIx::Class::AuditAny>
579              
580             =item *
581              
582             L<DBIx::Class>
583              
584             =back
585              
586             =head1 SUPPORT
587            
588             IRC:
589            
590             Join #rapidapp on irc.perl.org.
591              
592             =head1 AUTHOR
593              
594             Henry Van Styn <vanstyn@cpan.org>
595              
596             =head1 COPYRIGHT AND LICENSE
597              
598             This software is copyright (c) 2012-2015 by IntelliTree Solutions llc.
599              
600             This is free software; you can redistribute it and/or modify it under
601             the same terms as the Perl 5 programming language system itself.
602              
603             =cut