File Coverage

blib/lib/Net/WAMP/Session.pm
Criterion Covered Total %
statement 56 91 61.5
branch 9 36 25.0
condition n/a
subroutine 17 26 65.3
pod 0 16 0.0
total 82 169 48.5


line stmt bran cond sub pod time code
1             package Net::WAMP::Session;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Net::WAMP::Session
8              
9             =head1 SYNOPSIS
10              
11             my $session = Net::WAMP::Session->new(
12              
13             #required
14             on_send => sub { ... },
15              
16             #optional; default is 'json'
17             serialization => 'msgpack',
18             );
19              
20             =head1 DISCUSSION
21              
22             The only thing externally documented about these objects is that
23             they exist and how to instantiate them. A future refactor might
24             obscure this functionality entirely—e.g., if the Router functionality
25             of Net::WAMP becomes widely used.
26              
27             Please do not use any of the methods on these objects directly,
28             as this interface is not at all meant to be stable.
29              
30             =cut
31              
32 1     1   367 use strict;
  1         1  
  1         84  
33 1     1   3 use warnings;
  1         1  
  1         20  
34              
35 1     1   4 use Types::Serialiser ();
  1         0  
  1         9  
36              
37 1     1   3 use Net::WAMP::Messages ();
  1         0  
  1         890  
38              
39             sub new {
40 2     2 0 13 my ($class, %opts) = @_;
41              
42 2         5 my @missing = grep { !$opts{$_} } qw( serialization on_send );
  4         10  
43 2 50       7 die 'Need “serialization”!' if !$opts{'serialization'};
44 2 50       6 die 'Need “on_send”!' if !$opts{'serialization'};
45              
46             my $self = bless {
47             _last_session_scope_id => 0,
48             #_send_queue => [],
49 2         7 _on_send => $opts{'on_send'},
50             }, $class;
51              
52 2         7 $self->_set_serialization_format($opts{'serialization'});
53              
54 2         8 return $self;
55             }
56              
57             sub send_message {
58 2     2 0 5 $_[0]->{'_on_send'}->( $_[0]->message_object_to_bytes($_[1]) );
59 2         6 return;
60             }
61              
62             sub get_next_session_scope_id {
63 1     1 0 1 my ($self) = @_;
64              
65 1         4 return ++$self->{'_last_session_scope_id'};
66             }
67              
68             sub message_bytes_to_object {
69 4     4 0 9 my ($self) = @_;
70              
71 4         9 my $array_ref = $self->_destringify($_[1]);
72              
73 4         6 my $type_num = shift(@$array_ref);
74 4         9 my $type = Net::WAMP::Messages::get_type($type_num);
75              
76 4         9 return $self->_create_msg( $type, @$array_ref );
77             }
78              
79             sub message_object_to_bytes {
80 4     4 0 13 my ($self, $wamp_msg) = @_;
81              
82 4         17 return $self->_stringify( $wamp_msg->to_unblessed() );
83             }
84              
85             sub set_peer_roles {
86 1     1 0 2 my ($self, $peer_roles_hr) = @_;
87              
88 1 50       3 if ($self->{'_peer_roles'}) {
89 0         0 die 'Already set peer roles!';
90             }
91              
92 1         2 $self->{'_peer_roles'} = $peer_roles_hr;
93              
94 1         2 return;
95             }
96              
97             sub peer_is {
98 1     1 0 2 my ($self, $role) = @_;
99              
100 1         3 $self->_verify_peer_roles_set();
101              
102 1 50       7 return $self->{'_peer_roles'}{$role} ? 1 : 0;
103             }
104              
105             sub peer_role_supports_boolean {
106 0     0 0 0 my ($self, $role, $feature) = @_;
107              
108 0 0       0 die "Need role!" if !length $role;
109 0 0       0 die "Need feature!" if !length $feature;
110              
111 0         0 $self->_verify_peer_roles_set();
112              
113 0 0       0 if ( my $brk = $self->{'_peer_roles'}{$role} ) {
114 0 0       0 if ( my $features_hr = $brk->{'features'} ) {
115 0         0 my $val = $features_hr->{$feature};
116 0 0       0 return 0 if !defined $val;
117              
118 0 0       0 if (!$val->isa('Types::Serialiser::Boolean')) {
119 0         0 die "“$role”/“$feature” ($val) is not a boolean value!";
120             }
121              
122 0         0 return Types::Serialiser::is_true($val);
123             }
124             }
125              
126 0         0 return 0;
127             }
128              
129             sub _verify_peer_roles_set {
130 1     1   2 my ($self) = @_;
131              
132 1 50       2 die 'No peer roles set!' if !$self->{'_peer_roles'};
133              
134 1         2 return;
135             }
136              
137             sub has_sent_GOODBYE {
138 0     0 0 0 return $_[0]->{'_sent_GOODBYE'};
139             }
140              
141             sub mark_sent_GOODBYE {
142 0     0 0 0 my ($self) = @_;
143              
144 0 0       0 if ($self->{'_sent_GOODBYE'}) {
145 0         0 die 'Already sent GOODBYE!';
146             }
147              
148 0         0 $self->{'_sent_GOODBYE'} = 1;
149              
150 0 0       0 if ($self->{'_received_GOODBYE'}) {
151 0         0 $self->{'_finished'} = 1;
152             }
153              
154 0         0 return;
155             }
156              
157             sub mark_received_GOODBYE {
158 0     0 0 0 my ($self) = @_;
159              
160 0         0 $self->{'_received_GOODBYE'} = 1;
161              
162 0 0       0 if ($self->{'_sent_GOODBYE'}) {
163 0         0 $self->{'_finished'} = 1;
164             }
165              
166 0         0 return;
167             }
168              
169             sub is_finished {
170 2 50   2 0 9 return $_[0]->{'_finished'} ? 1 : undef;
171             }
172              
173             #sub enqueue_message_to_send {
174             # my ($self, $msg) = @_;
175             #
176             # push @{ $self->{'_send_queue'} }, $msg;
177             #
178             # return;
179             #}
180             #
181             #sub shift_message_queue {
182             # my ($self, $msg) = @_;
183             #
184             # return undef if !@{ $self->{'_send_queue'} };
185             #
186             # return $self->message_object_to_bytes(
187             # shift @{ $self->{'_send_queue'} },
188             # );
189             #}
190              
191             sub shutdown {
192 0     0 0 0 $_[0]{'_is_shut_down'} = 1;
193 0         0 return;
194             }
195              
196             sub is_shut_down {
197 0     0 0 0 return $_[0]{'_is_shut_down'};
198             }
199              
200             sub get_serialization {
201 0     0 0 0 my ($self) = @_;
202              
203 0         0 return $self->{'_serialization'};
204             }
205              
206             sub get_websocket_data_type {
207 0     0 0 0 my ($self) = shift;
208 0         0 return $self->{'_serialization_module'}->websocket_data_type();
209             }
210              
211             #----------------------------------------------------------------------
212              
213             sub _set_serialization_format {
214 2     2   3 my ($self, $serialization) = @_;
215              
216 2         5 my $ser_mod = "Net::WAMP::Serialization::$serialization";
217 2 100       16 Module::Load::load($ser_mod) if !$ser_mod->can('stringify');
218              
219 2         15 $self->{'_serialization'} = $serialization;
220 2         4 $self->{'_serialization_module'} = $ser_mod;
221              
222 2         1 return $self;
223             }
224              
225             sub _serialization_is_set {
226 0     0   0 my ($self) = @_;
227              
228 0 0       0 return $self->{'_serialization_module'} ? 1 : 0;
229             }
230              
231             sub _stringify {
232 4     4   5 my ($self) = shift;
233 4         95 return $self->{'_serialization_module'}->can('stringify')->(@_);
234             }
235              
236             sub _destringify {
237 4     4   5 my ($self) = shift;
238 4         42 return $self->{'_serialization_module'}->can('parse')->(@_);
239             }
240              
241             #----------------------------------------------------------------------
242              
243             #XXX De-duplicate TODO
244             sub _create_msg {
245 4     4   9 my ($self, $name, @parts) = @_;
246              
247 4         6 my $mod = "Net::WAMP::Message::$name";
248 4 50       24 Module::Load::load($mod) if !$mod->can('new');
249              
250 4         11 return $mod->new(@parts);
251             }
252              
253             #----------------------------------------------------------------------
254              
255             1;