File Coverage

blib/lib/Net/WAMP/Role/Base/Peer.pm
Criterion Covered Total %
statement 57 101 56.4
branch 10 34 29.4
condition 2 6 33.3
subroutine 13 21 61.9
pod 0 4 0.0
total 82 166 49.4


line stmt bran cond sub pod time code
1             package Net::WAMP::Role::Base::Peer;
2              
3 1     1   416 use strict;
  1         1  
  1         22  
4 1     1   3 use warnings;
  1         1  
  1         18  
5              
6 1     1   2 use Module::Load ();
  1         11  
  1         12  
7              
8 1     1   3 use constant REQUIRE_STRICT_PEER_ROLES => 1;
  1         1  
  1         57  
9              
10 1     1   3 use constant PEER_CAN_ACCEPT => qw( GOODBYE ABORT ERROR );
  1         1  
  1         1139  
11              
12             #----------------------------------------------------------------------
13              
14             sub handle_message {
15 2     2 0 3 my ($self) = @_;
16              
17 2         8 my $msg = $self->{'_session'}->message_bytes_to_object($_[1]);
18              
19 2         20 my ($handler_cr, $handler2_cr) = $self->_get_message_handlers($msg);
20              
21 2         4 local $self->{'_prevent_custom_handler'};
22              
23 2         7 my @extra_args = $handler_cr->( $self, $msg );
24              
25             #Check for external method definition
26 2 100 66     13 if (!$self->{'_prevent_custom_handler'} && $handler2_cr) {
27 1         3 $handler2_cr->( $self, $msg, @extra_args );
28             }
29              
30 2         12 return $msg;
31             }
32              
33             sub send_GOODBYE {
34 0     0 0 0 my ($self, $details_hr, $reason) = @_;
35              
36 0   0     0 $reason ||= $self->DEFAULT_GOODBYE_REASON();
37              
38 0         0 $self->{'_session'}->mark_sent_GOODBYE();
39              
40 0         0 my $msg = $self->_create_and_send_msg( 'GOODBYE', $details_hr, $reason );
41              
42 0         0 return $msg;
43             }
44              
45             sub send_ABORT {
46 0     0 0 0 my ($self, $details_hr, $reason) = @_;
47              
48 0         0 return $self->_create_and_send_msg( 'ABORT', $details_hr, $reason );
49             }
50              
51 1     1 0 4 sub get_agent_string { return ref $_[0] }
52              
53             #----------------------------------------------------------------------
54              
55             sub _receive_GOODBYE {
56 0     0   0 my ($self, $msg) = @_;
57              
58 0         0 $self->{'_session'}->mark_received_GOODBYE();
59              
60 0 0       0 if (!$self->{'_session'}->has_sent_GOODBYE()) {
61 0         0 $self->send_GOODBYE(
62             $msg->get('Details'),
63             'wamp.error.goodbye_and_out',
64             );
65             }
66              
67 0         0 return $self;
68             }
69              
70             sub _receive_ERROR {
71 0     0   0 my ($self, $msg) = @_;
72              
73 0         0 my $subtype = $msg->get_request_type();
74 0         0 my $subhandler_n = "_receive_ERROR_$subtype";
75              
76 0         0 return $self->$subhandler_n($msg);
77             }
78              
79             sub _ABORT_from_protocol_error {
80 0     0   0 my ($self, $msg) = @_;
81              
82 0 0       0 $self->send_ABORT(
83             {
84             ( $msg ? (message => $msg) : () ),
85             },
86             'net_wamp.protocol_error',
87             );
88             }
89              
90             sub _send_msg {
91 2     2   3 my ($self, $msg) = @_;
92              
93 2 50       14 if ($self->{'_session'}->is_finished()) {
94 0         0 die "Session ($self->{'_session'}) is already finished!";
95             }
96              
97 2         8 $self->_check_peer_roles_before_send($msg);
98              
99 2         7 $self->{'_session'}->send_message($msg);
100              
101 2         3 return $self;
102             }
103              
104             sub _create_and_send_msg {
105 1     1   3 my ($self, $name, @parts) = @_;
106              
107             #This is in Peer.pm
108 1         36 my $msg = $self->_create_msg($name, @parts);
109              
110 1         8 $self->_send_msg($msg);
111              
112 1         6 return $msg;
113             }
114              
115             sub _create_and_send_session_msg {
116 1     1   2 my ($self, $name, @parts) = @_;
117              
118             #This is in Peer.pm
119             my $msg = $self->_create_msg(
120             $name,
121 1         5 $self->{'_session'}->get_next_session_scope_id(),
122             @parts,
123             );
124              
125 1         4 $self->_send_msg($msg);
126              
127 1         3 return $msg;
128             }
129              
130             sub _get_message_handlers {
131 2     2   4 my ($self, $msg) = @_;
132              
133             #$self->_verify_handshake();
134              
135 2         5 my $type = $msg->get_type();
136              
137 2         16 my $handler_cr = $self->can("_receive_$type");
138 2 50       6 if (!$handler_cr) {
139 0         0 die "“$self” received a message of type “$type” but cannot handle messages of this type!";
140             }
141              
142 2         9 my $handler2_cr = $self->can("on_$type");
143              
144 2         5 return ($handler_cr, $handler2_cr);
145             }
146              
147             sub _verify_handshake {
148 0     0   0 my ($self) = @_;
149              
150 0 0       0 die "Need WAMP handshake first!" if !$self->{'_handshake_done'};
151              
152 0         0 return;
153             }
154              
155             #or else send “wamp.error.invalid_uri”
156             #WAMP’s specification gives: re.compile(r"^([^\s\.#]+\.)*([^\s\.#]+)$")
157              
158             sub _validate_uri {
159 0     0   0 my ($self, $specimen) = @_;
160              
161 0 0       0 if ($specimen =~ m<\.\.>o) {
162 0         0 die Net::WAMP::X->create('BadURI', 'empty URI component', $specimen);
163             }
164              
165 0 0       0 if (0 == index($specimen, '.')) {
166 0         0 die Net::WAMP::X->create('BadURI', 'initial “.”', $specimen);
167             }
168              
169 0 0       0 if (substr($specimen, -1) eq '.') {
170 0         0 die Net::WAMP::X->create('BadURI', 'trailing “.”', $specimen);
171             }
172              
173 0 0       0 if ($specimen =~ tr<#><>) {
174 0         0 die Net::WAMP::X->create('BadURI', '“#” is forbidden', $specimen);
175             }
176              
177             #XXX https://github.com/wamp-proto/wamp-proto/issues/275
178 0 0       0 if ($specimen =~ m<\s>o) {
179 0         0 die Net::WAMP::X->create('BadURI', 'Whitespace is forbidden.', $specimen);
180             }
181              
182 0         0 return;
183             }
184              
185             #XXX De-duplicate TODO
186             sub _create_msg {
187 2     2   6 my ($self, $name, @parts) = @_;
188              
189 2         5 my $mod = "Net::WAMP::Message::$name";
190 2 50       24 Module::Load::load($mod) if !$mod->can('new');
191              
192 2         29 return $mod->new(@parts);
193             }
194              
195             #This happens during handshake.
196             sub _receive_ABORT {
197 0     0   0 my ($self, $msg) = @_;
198              
199 0         0 require Data::Dumper;
200 0         0 warn Data::Dumper::Dumper('received ABORT', $msg);
201              
202             #die "$msg: " . $self->_stringify($msg); #XXX
203              
204 0         0 return;
205             }
206              
207             sub _verify_receiver_can_accept_msg_type {
208 2     2   3 my ($self, $msg_type) = @_;
209              
210 2         4 my $session = $self->{'_session'};
211              
212 2 100       8 if (!grep { $_ eq $msg_type } $self->PEER_CAN_ACCEPT()) {
  8         14  
213 1         2 my $role;
214              
215 1 50       9 my $cr = $self->can("receiver_role_of_$msg_type") or do {
216 0         0 die "I don’t know what role accepts “$msg_type” messages!";
217             };
218              
219 1         3 $role = $cr->();
220              
221 1 50       4 if (!$session->peer_is( $role )) {
222 0         0 die Net::WAMP::X->create(
223             'PeerLacksMessageRecipientRole',
224             $msg_type,
225             $role,
226             );
227             }
228              
229 1 50       9 if (my $cr = $self->can("receiver_feature_of_$msg_type")) {
230 0 0       0 if (!$session->peer_role_supports_boolean( $role, $cr->() )) {
231 0         0 my $feature_name = $cr->();
232 0         0 die Net::WAMP::X->create(
233             'PeerLacksMessageRecipientFeature',
234             $msg_type,
235             $feature_name,
236             );
237             }
238             }
239             }
240              
241 2         5 return;
242             }
243              
244             1;