File Coverage

blib/lib/Net/STOMP/Client/HeartBeat.pm
Criterion Covered Total %
statement 29 79 36.7
branch 1 32 3.1
condition 0 22 0.0
subroutine 9 17 52.9
pod 5 5 100.0
total 44 155 28.3


line stmt bran cond sub pod time code
1             #+##############################################################################
2             # #
3             # File: Net/STOMP/Client/HeartBeat.pm #
4             # #
5             # Description: Heart-beat support for Net::STOMP::Client #
6             # #
7             #-##############################################################################
8              
9             #
10             # module definition
11             #
12              
13             package Net::STOMP::Client::HeartBeat;
14 1     1   4 use strict;
  1         1  
  1         24  
15 1     1   3 use warnings;
  1         1  
  1         59  
16             our $VERSION = "2.3";
17             our $REVISION = sprintf("%d.%02d", q$Revision: 2.4 $ =~ /(\d+)\.(\d+)/);
18              
19             #
20             # used modules
21             #
22              
23 1     1   3 use No::Worries::Die qw(dief);
  1         1  
  1         5  
24 1     1   69 use No::Worries::Export qw(export_control);
  1         2  
  1         3  
25 1     1   55 use Params::Validate qw(validate_pos :types);
  1         1  
  1         118  
26 1     1   5 use Time::HiRes qw();
  1         1  
  1         594  
27              
28             #
29             # get/set the client heart-beat
30             #
31              
32             sub client_heart_beat : method {
33 0     0 1 0 my($self, $value);
34              
35 0         0 $self = shift(@_);
36 0 0       0 return($self->{"client_heart_beat"}) if @_ == 0;
37 0         0 $value = $_[0];
38 0 0 0     0 if (@_ == 1 and defined($value) and ref($value) eq "") {
      0        
39 0         0 $self->{"client_heart_beat"} = $value;
40 0         0 return($self);
41             }
42             # otherwise complain...
43 0         0 validate_pos(@_, { optional => 1, type => SCALAR });
44             }
45              
46             #
47             # get/set the server heart-beat
48             #
49              
50             sub server_heart_beat : method {
51 0     0 1 0 my($self, $value);
52              
53 0         0 $self = shift(@_);
54 0 0       0 return($self->{"server_heart_beat"}) if @_ == 0;
55 0         0 $value = $_[0];
56 0 0 0     0 if (@_ == 1 and defined($value) and ref($value) eq "") {
      0        
57 0         0 $self->{"server_heart_beat"} = $value;
58 0         0 return($self);
59             }
60             # otherwise complain...
61 0         0 validate_pos(@_, { optional => 1, type => SCALAR });
62             }
63              
64             #
65             # get the last time we received/read data
66             #
67              
68             sub last_received : method {
69 0     0 1 0 my($self) = @_;
70              
71 0 0       0 return(undef) unless $self->{"io"};
72 0         0 return($self->{"io"}{"incoming_time"});
73             }
74              
75             #
76             # get the last time we sent/wrote data
77             #
78              
79             sub last_sent : method {
80 0     0 1 0 my($self) = @_;
81              
82 0 0       0 return(undef) unless $self->{"io"};
83 0         0 return($self->{"io"}{"outgoing_time"});
84             }
85              
86             #
87             # send a NOOP frame only if needed wrt heart-beat settings
88             #
89              
90             sub beat : method {
91 0     0 1 0 my($self, %option) = @_;
92 0         0 my($delta, $sent);
93              
94             # check if client heart-beats are expected
95 0         0 $delta = $self->client_heart_beat();
96 0 0       0 return($self) unless $delta;
97             # check the last time we sent data
98 0         0 $sent = $self->last_sent();
99 0 0       0 return($self) if Time::HiRes::time() - $sent < $delta / 2;
100             # send a NOOP frame
101 0         0 return($self->noop(%option));
102             }
103              
104             #
105             # setup
106             #
107              
108             sub _setup ($) {
109 1     1   1 my($self) = @_;
110              
111             # additional options for new()
112             return(
113 1 50       11 "client_heart_beat" => { optional => 1, type => SCALAR },
114             "server_heart_beat" => { optional => 1, type => SCALAR },
115             ) unless $self;
116             }
117              
118             #
119             # hook for the CONNECT frame
120             #
121              
122             sub _connect_hook ($$) {
123 0     0   0 my($self, $frame) = @_;
124 0         0 my($chb, $shb);
125              
126             # do not override what the user did put in the frame
127 0 0       0 return if defined($frame->header("heart-beat"));
128             # do nothing when only STOMP 1.0 is asked
129 0 0       0 return unless grep($_ ne "1.0", $self->accept_version());
130             # add the appropriate header (in milliseconds!)
131 0   0     0 $chb = int(($self->client_heart_beat() || 0) * 1000.0 + 0.5);
132 0   0     0 $shb = int(($self->server_heart_beat() || 0) * 1000.0 + 0.5);
133 0 0 0     0 $frame->header("heart-beat", "$chb,$shb") if $chb or $shb;
134             }
135              
136             #
137             # negotiation helper
138             #
139              
140             sub _maxif ($$) {
141 0     0   0 my($x, $y) = @_;
142              
143 0 0 0     0 return(0) unless $x and $y;
144 0 0       0 return($x > $y ? $x : $y);
145             }
146              
147             #
148             # hook for the CONNECTED frame
149             #
150              
151             sub _connected_hook ($$) {
152 0     0   0 my($self, $frame) = @_;
153 0         0 my($value, $shb, $chb);
154              
155 0         0 $value = $frame->header("heart-beat");
156 0 0       0 if (defined($value)) {
157             # given specification: check
158 0 0       0 if ($value =~ /^(\d+),(\d+)$/) {
159 0         0 ($shb, $chb) = ($1 / 1000.0, $2 / 1000.0);
160 0         0 $self->server_heart_beat(_maxif($self->server_heart_beat(), $shb));
161 0         0 $self->client_heart_beat(_maxif($self->client_heart_beat(), $chb));
162             } else {
163 0         0 dief("unexpected heart-beat specification: %s", $value);
164             }
165             } else {
166             # missing specification: disable
167 0         0 $self->client_heart_beat(0);
168 0         0 $self->server_heart_beat(0);
169             }
170             }
171              
172             #
173             # register the setup and hooks
174             #
175              
176             {
177 1     1   5 no warnings qw(once);
  1         2  
  1         155  
178             $Net::STOMP::Client::Setup{"heart-beat"} = \&_setup;
179             $Net::STOMP::Client::Hook{"CONNECT"}{"heart-beat"} = \&_connect_hook;
180             $Net::STOMP::Client::Hook{"CONNECTED"}{"heart-beat"} = \&_connected_hook;
181             }
182              
183             #
184             # export control
185             #
186              
187             sub import : method {
188 1     1   1 my($pkg, %exported);
189              
190 1         2 $pkg = shift(@_);
191 1         2 grep($exported{$_}++, qw(beat));
192 1         4 grep($exported{$_}++, map("${_}_heart_beat", qw(client server)));
193 1         3 grep($exported{$_}++, map("last_${_}", qw(received sent)));
194 1         5 export_control(scalar(caller()), $pkg, \%exported, @_);
195             }
196              
197             1;
198              
199             __END__