File Coverage

blib/lib/Test/Mock/Signature/Dispatcher.pm
Criterion Covered Total %
statement 60 60 100.0
branch 4 4 100.0
condition 1 3 33.3
subroutine 14 14 100.0
pod 4 4 100.0
total 83 85 97.6


line stmt bran cond sub pod time code
1             package Test::Mock::Signature::Dispatcher;
2              
3 4     4   19 use strict;
  4         5  
  4         138  
4 4     4   20 use warnings;
  4         26  
  4         102  
5              
6 4     4   1748 use Data::PatternCompare;
  4         44341  
  4         17  
7              
8             sub new {
9 5     5 1 7 my $class = shift;
10 5         6 my $method = shift;
11              
12 5         31 my $params = {
13             _method => $method,
14             _list => [],
15             _cmp => Data::PatternCompare->new,
16             _default => undef,
17             };
18 5         84 return bless($params, $class);
19             }
20              
21             sub add {
22 7     7 1 8 my $self = shift;
23 7         10 my $meta = shift;
24 7         17 my $list = $self->{'_list'};
25 7         10 my $cmp = $self->{'_cmp'};
26              
27 7         30 @$list = sort { $cmp->compare_pattern($a->params, $b->params) } @$list, $meta;
  2         6  
28             }
29              
30             sub delete {
31 2     2 1 3 my $self = shift;
32 2         3 my $meta = shift;
33 2         3 my $list = $self->{'_list'};
34 2         3 my $cmp = $self->{'_cmp'};
35              
36 2         4 @$list = grep { !$cmp->eq_pattern($_->params, $meta->params) } @$list;
  4         116  
37             }
38              
39             sub compile {
40 7     7 1 10 my $self = shift;
41 7 100       22 return if defined $self->{'_default'};
42              
43 5         9 my $list = $self->{'_list'};
44 5         8 my $cmp = $self->{'_cmp'};
45              
46 5   33     18 $self->{'_default'} ||= do {
47 4     4   985 no strict 'refs';
  4         6  
  4         474  
48              
49 5         4 *{$self->{'_method'}}{'CODE'}
  5         25  
50             };
51 5         8 my $default = $self->{'_default'};
52              
53             my $code = sub {
54 13     13   1321 my ($self, @params) = @_;
55              
56 13         26 for my $meta ( @$list ) {
57 15 100       109 if ($cmp->pattern_match(\@params, $meta->params)) {
58 9         481 my $cb = $meta->callback;
59              
60 9         29 goto &$cb;
61             }
62             }
63              
64 4         194 goto &$default;
65 5         24 };
66              
67 4     4   21 no strict 'refs';
  4         5  
  4         124  
68 4     4   19 no warnings 'redefine';
  4         12  
  4         328  
69 5         8 *{$self->{'_method'}} = $code;
  5         24  
70             }
71              
72             sub DESTROY {
73 5     5   7 my $self = shift;
74 5         9 my $method = $self->{'_method'};
75              
76 4     4   23 no strict 'refs';
  4         4  
  4         102  
77 4     4   16 no warnings 'redefine';
  4         7  
  4         207  
78 5         103 *$method = $self->{'_default'};
79             }
80              
81             42;
82              
83             __END__