File Coverage

blib/lib/Net/WebSocket/Frame/close.pm

Criterion	Covered	Total	%
statement	49	54	90.7
branch	18	22	81.8
condition	5	9	55.5
subroutine	9	9	100.0
pod	0	2	0.0
total	81	96	84.3

package Net::WebSocket::Frame::close;

=encoding utf-8

=head1 NAME

Net::WebSocket::Frame::close

=head1 SYNOPSIS

    my $frm = Net::WebSocket::Frame::close->new(

        #Optional, can be either empty (default) or four random bytes
        mask => q<>,

        code => 'SUCCESS',      #See below

        reason => 'yeah, baby', #See below
    );

    $frm->get_type();           #"close"

    $frm->is_control();   #1

    my $mask = $frm->get_mask_bytes();

    my ($code, $reason) = $frm->get_code_and_reason();

    #If, for some reason, you need the raw payload:
    my $payload = $frm->get_payload();

    my $serialized = $frm->to_bytes();

Note that, L,
close messages can have any of:

=over

=item * no code, and no reason

Returned as undef (for the code) and an empty string. This diverges
from the RFC’s described behavior of returning code 1005.

=item * a code, and no reason

Returned as the code number and an empty string.

=item * a code, and a reason that cannot exceed 123 bytes

=back

The code (i.e., C<$code>) is subject to
L.
You can also, in lieu of a numeric constant, use the following string
constants that derive from L:

=over

=item * C (1000)

=item * C (1001)

=item * C (1002)

=item * C (1003)

=item * C (1007)

=item * C (1008)

=item * C (1009)

=item * C (1010)

=item * C, aka C (1011)

This appears as C in Microsoft’s documentation; however,
L updates
the RFC to have this status encompass client errors as well.

Net::WebSocket recognizes either string, but its parsing logic will return
only C.

=back

The following additional status constants derive from
L
and are newer than either RFC 6455 or Microsoft’s API:

=over

=item * C (1012)

=item * C (1013)

=item * C (1014)

=back

It is hoped that a future update to the WebSocket specification
can include these or similar constant names.

=cut

use strict;
use warnings;

use parent qw(
    Net::WebSocket::Base::ControlFrame
);

use Call::Context ();

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

use constant get_opcode => 8;

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

    if (!$opts{'payload_sr'} && !defined $opts{'payload'}) {
        my $payload;

        if (my $code = delete $opts{'code'}) {
            my $num = Net::WebSocket::Constants::status_name_to_code($code);
            if (!$num) {
                $num = $code;

                if ($num !~ m<\A[1-4][0-9]{3}\z> ) {
                    die Net::WebSocket::X->create('BadArg', 'code', $num, "Invalid WebSocket status code ($num) given");
                }

                if ( !Net::WebSocket::Constants::status_code_to_name($num) ) {
                    if ( $num < 4000 || $num > 4999 ) {
                        die Net::WebSocket::X->create('BadArg', 'code', $num, "Disallowed WebSocket status code ($num) given");
                    }
                }
            }

            $payload = pack 'n', $num;

            my $reason = delete $opts{'reason'};
            if (defined $reason) {
                if (length $reason > 123) {
                    die Net::WebSocket::X->create('BadArg', 'reason', $reason, 'Reason cannot exceed 123 bytes!');
                }

                $payload .= $reason;
            }
        }
        else {
            my $reason = delete $opts{'reason'};

            if (defined $reason && length $reason) {
                warn "close frame constructor received “reason” ($opts{'reason'}) but no “code”!";
            }

            $payload = q<>;
        }

        $opts{'payload'} = $payload;
    }

    return $class->SUPER::new( %opts );
}

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

    Call::Context::must_be_list();

    #This shouldn’t happen … maybe leftover from previous architecture?
    if ($self->get_type() ne 'close') {
        my $type = $self->get_type();
        die "Frame type is “$type”, not “close” as expected!";
    }

    if (!length ${ $self->[$self->PAYLOAD] }) {
        return ( undef, q<> );
    }

    return unpack 'na*', $self->get_payload();
}

1;