view release on metacpan or  search on metacpan

t/conformance/mdns-imsg.t  view on Meta::CPAN

#!/usr/bin/env perl
# ex:ts=8 sw=4:
# Conformance tests for spec/protocol/MDNS-Imsg.md
#
# The framing is Protocol::Imsg, so most sections drive the codec over
# bytes. Two predicates are not framing at all: an invalid len drops
# the connection, and EOF mid-message is an error. A codec with append
# and next_message has no concept of a connection or an EOF, so both
# keep their socketpair against Fugu::Imsg.

use v5.36;
use Test::More;
use FindBin qw($RealBin);
use lib "$RealBin/../../lib";
use Socket qw(AF_UNIX SOCK_STREAM PF_UNSPEC);

use_ok('Protocol::Imsg');
use_ok('Fugu::Imsg');

# pair(): a Fugu::Imsg endpoint and the raw peer handle. Thus a test
# can inject wire bytes that the transport would never produce.
sub pair ()
{
	socketpair( my $a, my $b, AF_UNIX, SOCK_STREAM, PF_UNSPEC )
	    or die "socketpair: $!";
	binmode $_ for $a, $b;
	return ( Fugu::Imsg->new( fh => $a ), $b );
}

subtest '[MDNS-Imsg §1] header is four uint32 fields in order' => sub {
	my $hdr = Protocol::Imsg::_encode_header( 0x11223344, 0x55667788,
		0x99aabbcc, 0xddeeff00 );

	is( length($hdr), 16, 'IMSG_HEADER_SIZE is 16' );

	# Field layout, not byte order: each field is in its own 4-byte
	# slot at the measured offset. The host byte order does not
	# matter.
	is( unpack( 'L', substr( $hdr, 0, 4 ) ),
		0x11223344, 'type at offset 0' );
	is( unpack( 'L', substr( $hdr, 4, 4 ) ),
		0x55667788, 'len at offset 4' );
	is( unpack( 'L', substr( $hdr, 8, 4 ) ),
		0x99aabbcc, 'peerid at offset 8' );
	is( unpack( 'L', substr( $hdr, 12, 4 ) ),
		0xddeeff00, 'pid at offset 12' );
};

subtest '[MDNS-Imsg §2] len counts header plus payload' => sub {
	my $wire =
	    Protocol::Imsg->new->encode( type => 8, data => 'x' x 240 );

	is( length($wire), 256, 'whole message is header + payload' );
	my ( $type, $len ) = unpack 'L2', $wire;
	is( $len, 256, 'len field includes the 16-byte header' );
};

subtest '[MDNS-Imsg §2] payload bound is MAX_IMSGSIZE minus header' =>
    sub {
	my $codec = Protocol::Imsg->new;

	ok( !defined $codec->encode( type => 1, data => 'x' x 16369 ),
		'payload above 16368 bytes is refused, not truncated' );
	ok( defined $codec->encode( type => 1, data => 'x' x 16368 ),
		'payload of exactly 16368 bytes is accepted' );
    };

subtest '[MDNS-Imsg §2] receiver masks the fd mark off len' => sub {
	my $codec = Protocol::Imsg->new;

	# A message whose len carries IMSG_FD_MARK still frames
	# correctly after the receiver masks off the mark
	$codec->append(
		pack( 'L4', 7, ( 16 + 4 ) | 0x80000000, 0, 1 ) . 'data' );
	my $msg = $codec->next_message;
	ok( defined $msg, 'marked message received' );
	is( $msg->{data}, 'data', 'payload length taken from masked len' );
};

# A dropped connection is a transport predicate: the codec records a