File Coverage

blib/lib/Cassandra/Client/Policy/LoadBalancing/Default.pm
Criterion Covered Total %
statement 14 67 20.9
branch 0 22 0.0
condition 0 11 0.0
subroutine 5 15 33.3
pod 0 10 0.0
total 19 125 15.2


line stmt bran cond sub pod time code
1             package Cassandra::Client::Policy::LoadBalancing::Default;
2             our $AUTHORITY = 'cpan:TVDW';
3             $Cassandra::Client::Policy::LoadBalancing::Default::VERSION = '0.13_007'; # TRIAL
4              
5 1     1   12 $Cassandra::Client::Policy::LoadBalancing::Default::VERSION = '0.13007';use 5.010;
  1         3  
6 1     1   5 use strict;
  1         1  
  1         16  
7 1     1   4 use warnings;
  1         1  
  1         29  
8 1     1   5 use List::Util 'shuffle';
  1         2  
  1         77  
9 1     1   6 use Time::HiRes qw/time/;
  1         2  
  1         7  
10              
11             sub new {
12 0     0 0   my ($class, %args)= @_;
13 0           return bless {
14             datacenter => undef,
15             nodes => {},
16             local_nodes => {},
17             connected => {},
18             candidates => [],
19             try_times => {},
20             }, $class;
21             }
22              
23             sub get_distance {
24 0     0 0   my ($self, $peer)= @_;
25 0           my $node= $self->{nodes}{$peer};
26 0 0         if (!$node) {
27 0           warn 'Being asked about a distance for a node we don\'t know';
28 0           return 'ignored';
29             }
30              
31 0 0         if ($self->{local_nodes}{$peer}) {
32 0           return 'local';
33             }
34 0           return 'remote';
35             }
36              
37             sub on_new_node {
38 0     0 0   my ($self, $node)= @_;
39              
40 0           my $peer= $node->{peer};
41 0 0         if ($self->{nodes}{$peer}) {
42 0           warn 'BUG: "new" node is already known!';
43             }
44              
45 0           $self->{nodes}{$peer}= $node;
46 0 0 0       if (!$self->{datacenter} || $node->{data_center} eq $self->{datacenter}) {
47 0           $self->{local_nodes}{$peer}= $node;
48             }
49             }
50              
51             sub on_removed_node {
52 0     0 0   my ($self, $node)= @_;
53              
54 0           my $peer= $node->{peer};
55 0 0         if (!$self->{nodes}{$peer}) {
56 0           warn 'BUG: "removed" node wasn\'t there!';
57             }
58              
59 0           delete $self->{nodes}{$peer};
60 0           delete $self->{local_nodes}{$peer};
61             }
62              
63             sub get_next_candidate {
64 0     0 0   my ($self)= @_;
65 0           my $candidates= $self->{candidates};
66 0           while (my $maybe= shift @$candidates) {
67 0 0 0       if ($self->{local_nodes}{$maybe} && !$self->{connected}{$maybe} && $self->check_backoff($maybe)) {
      0        
68 0           return $maybe;
69             }
70             }
71 0 0         @$candidates= shuffle grep { !$self->{connected}{$_} && $self->check_backoff($_) } keys %{$self->{local_nodes}};
  0            
  0            
72 0           return shift @$candidates;
73             }
74              
75             my @all_backoff= map { $_ * (rand()*.4 + 0.8) } (1, 5, 20, 60, 180, 600);
76             sub check_backoff {
77 0     0 0   my ($self, $peer)= @_;
78 0           my $times= $self->{try_times}{$peer};
79 0 0         return 1 unless $times;
80              
81 0           my $count= 0+@$times;
82 0 0         $count= @all_backoff if $count > @all_backoff;
83 0           my $backoff= $all_backoff[$count-1];
84              
85 0 0         if (time() - $times->[-1] < $backoff) {
86 0           return;
87             }
88              
89 0           return 1;
90             }
91              
92             sub set_connecting {
93 0     0 0   my ($self, $peer)= @_;
94 0           $self->{connected}{$peer}= 1;
95 0   0       push @{$self->{try_times}{$peer} ||= []}, time;
  0            
96             }
97              
98             sub set_connected {
99 0     0 0   my ($self, $peer)= @_;
100 0 0         warn "BUG" unless $self->{connected}{$peer};
101 0           delete $self->{try_times}{$peer};
102             }
103              
104             sub set_disconnected {
105 0     0 0   my ($self, $peer)= @_;
106 0           delete $self->{connected}{$peer};
107             }
108              
109             sub known_node_count {
110 0     0 0   my ($self)= @_;
111 0           return (0+ keys %{$self->{local_nodes}});
  0            
112             }
113              
114             1;
115              
116             __END__