File Coverage

blib/lib/Net/WebSocket/Defragmenter.pm
Criterion Covered Total %
statement 34 35 97.1
branch 17 20 85.0
condition n/a
subroutine 5 5 100.0
pod 2 2 100.0
total 58 62 93.5


line stmt bran cond sub pod time code
1             package Net::WebSocket::Defragmenter;
2              
3 11     11   77 use strict;
  11         23  
  11         323  
4 11     11   53 use warnings;
  11         25  
  11         4754  
5              
6             =encoding utf-8
7              
8             =head1 NAME
9              
10             Net::WebSocket::Defragmenter
11              
12             =head1 SYNOPSIS
13              
14             my $defragger = Net::WebSocket::Defragmenter->new(
15             parser => $parser_obj, #i.e., isa Net::WebSocket::Parser
16              
17             #Optional; these two receive the Net::WebSocket::Frame object.
18             on_control_frame => sub { ... },
19             on_data_frame => sub { ... },
20              
21             #Optional; receives a type string and a human-readable message.
22             #An exception is thrown after this callback runs.
23             on_protocol_error => sub { ... },
24             );
25              
26             my $msg_or_undef = $defragger->get_next_message();
27              
28             =head1 DESCRIPTION
29              
30             You ordinarily shouldn’t instantiate this class because
31             L already uses it.
32              
33             This class implements WebSocket’s defragmentation logic.
34             It’s mostly meant for internal use but is documented for cases
35             where L may not be usable or desirable.
36              
37             =cut
38              
39             =head1 METHODS
40              
41             =head2 I->new( %OPTS )
42              
43             See SYNOPSIS above.
44              
45             =cut
46              
47             sub new {
48 10     10 1 73 my ($class, %opts) = @_;
49              
50             my %self = (
51             _fragments => [],
52              
53 10         53 ( map { ( "_$_" => $opts{$_} ) } (
  40         156  
54             'parser',
55             'on_control_frame',
56             'on_data_frame',
57             'on_protocol_error',
58             ) ),
59             );
60              
61 10         70 return bless \%self, $class;
62             }
63              
64             =head2 I->get_next_message()
65              
66             Reads a frame from C.
67              
68             Returns a L object if there is a message
69             ready to return; otherwise returns undef.
70              
71             An exception (L) is thrown on fragmentation errors.
72              
73             =cut
74              
75             sub get_next_message {
76 23     23 1 54 my ($self) = @_;
77              
78 23         43 my $_msg_frame;
79              
80 23 100       110 if ( $_msg_frame = $self->{'_parser'}->get_next_frame() ) {
81 22 100       166 if ($_msg_frame->is_control()) {
82 7 50       30 if ($self->{'_on_control_frame'}) {
83 7         37 $self->{'_on_control_frame'}->($_msg_frame);
84             }
85             }
86             else {
87 15 50       52 if ($self->{'_on_data_frame'}) {
88 0         0 $self->{'_on_data_frame'}->($_msg_frame);
89             }
90              
91             #Failure cases:
92             # - continuation without prior fragment
93             # - non-continuation within fragment
94              
95 15 100       65 if ( $_msg_frame->get_type() eq 'continuation' ) {
    100          
96 6 100       13 if ( !@{ $self->{'_fragments'} } ) {
  6         21  
97 1         4 $self->_on_protocol_error(
98             'ReceivedBadControlFrame',
99             sprintf('Received continuation outside of fragment!'),
100             );
101             }
102             }
103 9         31 elsif ( @{ $self->{'_fragments'} } ) {
104 1         5 $self->_on_protocol_error(
105             'ReceivedBadDataFrame',
106             sprintf('Received %s; expected continuation!', $_msg_frame->get_type())
107             );
108             }
109              
110 13 100       61 if ($_msg_frame->get_fin()) {
111             return Net::WebSocket::Message->new(
112 7         17 splice( @{ $self->{'_fragments'} } ),
  7         55  
113             $_msg_frame,
114             );
115             }
116             else {
117 6         13 push @{ $self->{'_fragments'} }, $_msg_frame;
  6         21  
118             }
119             }
120              
121 13         29 $_msg_frame = undef;
122             }
123              
124 14 100       102 return defined($_msg_frame) ? q<> : undef;
125             }
126              
127             sub _on_protocol_error {
128 2     2   8 my ($self, $type, $msg) = @_;
129              
130 2 50       7 if ( $self->{'_on_protocol_error'} ) {
131 2         9 $self->{'_on_protocol_error'}->( $type, $msg );
132             }
133              
134 2         1308 die Net::WebSocket::X->create( $type, $msg );
135             }
136              
137             1;