File Coverage

blib/lib/Net/WebSocket/Parser.pm

Criterion	Covered	Total	%
statement	80	86	93.0
branch	33	38	86.8
condition	4	5	80.0
subroutine	10	10	100.0
pod	1	2	50.0
total	128	141	90.7

package Net::WebSocket::Parser;

=encoding utf-8

=head1 NAME

Net::WebSocket::Parser - Parse WebSocket from a filehandle

=head1 SYNOPSIS

    my $iof = IO::Framed::Read->new($fh);

    my $parse = Net::WebSocket::Parser->new($iof);

    #See below for error responses
    my $frame = $parse->get_next_frame();

C<$iof> should normally be an instance of L. You’re free to
pass in anything with a C method, but that method must implement
the same behavior as C.

=head1 METHODS

=head2 I->get_next_frame()

A call to this method yields one of the following:

=over

=item * If a frame can be read, it will be returned.

=item * If only a partial frame is ready, undef is returned.

=head1 I/O DETAILS

L was born out of work on this module; see that module’s
documentation for the particulars of working with it. In particular,
note the exceptions L and
L. (As described in L’s
documentation, you can use an equivalent interface for frame chunking if you
wish.)

=head1 CUSTOM FRAMES SUPPORT

To support reception of custom frame types you’ll probably want to subclass
this module and define a specific custom constant for each supported opcode,
e.g.:

    package My::WebSocket::Parser;

    use parent qw( Net::WebSocket::Parser );

    use constant OPCODE_CLASS_3 => 'My::WebSocket::Frame::booya';

… where C is itself a subclass of
C.

You can also use this to override the default
classes for built-in frame types; e.g., C will override
L as the class will be used for pong frames
that this module receives. That could be useful, e.g., for compression
extensions, where you might want the C method to
decompress so that that detail is abstracted away.

=cut

use strict;
use warnings;

use Module::Load ();

use Net::WebSocket::Constants ();
use Net::WebSocket::X ();

use constant {
    OPCODE_CLASS_0 => 'Net::WebSocket::Frame::continuation',
    OPCODE_CLASS_1 => 'Net::WebSocket::Frame::text',
    OPCODE_CLASS_2 => 'Net::WebSocket::Frame::binary',
    OPCODE_CLASS_8 => 'Net::WebSocket::Frame::close',
    OPCODE_CLASS_9 => 'Net::WebSocket::Frame::ping',
    OPCODE_CLASS_10 => 'Net::WebSocket::Frame::pong',
};

sub new {
    my ($class, $reader) = @_;

    if (!(ref $reader)->can('read')) {
        die "“$reader” needs a read() method!";
    }

    return bless {
        _reader => $reader,
    }, $class;
}

sub get_next_frame {
    my ($self) = @_;

    local $@;

    if (!exists $self->{'_partial_frame'}) {
        $self->{'_partial_frame'} = q<>;
    }

    #It is really, really inconvenient that Perl has no “or” operator
    #that considers q<> falsey but '0' truthy. :-/
    #That aside, if indeed all we read is '0', then we know that’s not
    #enough, and we can return.
    my $first2 = $self->_read_with_buffer(2) or return undef;

    #Now that we’ve read our header bytes, we’ll read some more.
    #There may not actually be anything to read, though, in which case
    #some readers will error (e.g., EAGAIN from a non-blocking filehandle).
    #From a certain ideal we’d return #on each individual read to allow
    #the reader to wait until there is more data ready; however, for
    #practicality (and speed) let’s go ahead and try to read the rest of
    #the frame. That means we need to set some flag to let the reader know
    #not to die() if there’s no more data currently, as we’re probably
    #expecting more soon to complete the frame.
    local $self->{'_reading_frame'} = 1;

    my ($oct1, $oct2) = unpack('CC', $first2 );

    my $len = $oct2 & 0x7f;

    my $mask_size = ($oct2 & 0x80) && 4;

    my $len_len = ($len == 0x7e) ? 2 : ($len == 0x7f) ? 8 : 0;
    my $len_buf = q<>;

    my ($longs, $long);

    if ($len_len) {
        $len_buf = $self->_read_with_buffer($len_len) or do {
            substr( $self->{'_partial_frame'}, 0, 0, $first2 );
            return undef;
        };

        if ($len_len == 2) {
            ($longs, $long) = ( 0, unpack('n', $len_buf) );
        }
        else {
            ($longs, $long) = ( unpack('NN', $len_buf) );
        }
    }
    else {
        ($longs, $long) = ( 0, $len );
    }

    my $mask_buf;
    if ($mask_size) {
        $mask_buf = $self->_read_with_buffer($mask_size) or do {
            substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf );
            return undef;
        };
    }
    else {
        $mask_buf = q<>;
    }

    my $payload = q<>;

    for ( 1 .. $longs ) {

        #32-bit systems don’t know what 2**32 is.
        #MacOS, at least, also chokes on sysread( 2**31, … )
        #(Is their size_t signed??), even on 64-bit.
        for ( 1 .. 4 ) {
            $self->_append_chunk( 2**30, \$payload ) or do {
                substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf . $mask_buf . $payload );
                return undef;
            };
        }
    }

    if ($long) {
        $self->_append_chunk( $long, \$payload ) or do {
            substr( $self->{'_partial_frame'}, 0, 0, $first2 . $len_buf . $mask_buf . $payload );
            return undef;
        };
    }

    $self->{'_partial_frame'} = q<>;

    my $opcode = $oct1 & 0xf;

    my $frame_class = $self->{'_opcode_class'}{$opcode} ||= do {
        my $class;
        if (my $cr = $self->can("OPCODE_CLASS_$opcode")) {
            $class = $cr->();
        }
        else {

            #Untyped because this is a coding error.
            die "$self: Unrecognized frame opcode: “$opcode”";
        }

        Module::Load::load($class) if !$class->can('new');

        $class;
    };

    return $frame_class->create_from_parse(\$first2, \$len_len, \$mask_buf, \$payload);
}

#This will only return exactly the number of bytes requested.
#If fewer than we want are available, then we return undef.
sub _read_with_buffer {
    my ($self, $length) = @_;

    #Prioritize the case where we read everything we need.

    if ( length($self->{'_partial_frame'}) < $length ) {
        my $deficit = $length - length($self->{'_partial_frame'});
        my $read = $self->{'_reader'}->read($deficit);

        if (!defined $read) {
            return undef;
        }

        return substr($self->{'_partial_frame'}, 0, length($self->{'_partial_frame'}), q<>) . $read;
    }

    return substr( $self->{'_partial_frame'}, 0, $length, q<> );
}

sub _append_chunk {
    my ($self, $length, $buf_sr) = @_;

    my $start_buf_len = length $$buf_sr;

    my $cur_buf;

    while (1) {
        my $read_so_far = length($$buf_sr) - $start_buf_len;

        $cur_buf = $self->_read_with_buffer($length - $read_so_far);
        return undef if !defined $cur_buf;

        $$buf_sr .= $cur_buf;

        last if (length($$buf_sr) - $start_buf_len) >= $length;
    }

    return 1;
}

1;