File Coverage

blib/lib/Net/DNS/RR/SVCB.pm

Criterion	Covered	Total	%
statement	213	213	100.0
branch	80	80	100.0
path			n/a
condition	11	11	100.0
subroutine	38	38	100.0
pod	6	12	100.0
total	348	354	100.0

package Net::DNS::RR::SVCB;

use strict;
use warnings;
our $VERSION = (qw$Id: SVCB.pm 2043 2026-01-14 13:35:59Z willem $)[2];

use base qw(Net::DNS::RR);


=head1 NAME

Net::DNS::RR::SVCB - DNS SVCB resource record

=cut

use integer;

use Net::DNS::DomainName;
use Net::DNS::RR::A;
use Net::DNS::RR::AAAA;
use Net::DNS::Text;
use MIME::Base64;


my %keybyname = (
	mandatory	       => 'key0',			# RFC9460(8)
	alpn		       => 'key1',			# RFC9460(7.1)
	'no-default-alpn'      => 'key2',			# RFC9460(7.1)
	port		       => 'key3',			# RFC9460(7.2)
	ipv4hint	       => 'key4',			# RFC9460(7.3)
	ech		       => 'key5',			# RFC9460
	ipv6hint	       => 'key6',			# RFC9460(7.3)
	dohpath		       => 'key7',			# RFC9461
	ohttp		       => 'key8',			# RFC9540(4)
	'tls-supported-groups' => 'key9',
	);


sub _decode_rdata {			## decode rdata from wire-format octet string
	my ( $self, $data, $offset ) = @_;

	my $limit = $self->{rdlength};
	my $rdata = $self->{rdata} = substr $$data, $offset, $limit;
	$self->{SvcPriority} = unpack 'n', $rdata;
	( $self->{TargetName}, $offset ) = Net::DNS::DomainName->decode( \$rdata, 2 );

	my $params = $self->{SvcParams} = [];
	while ( ( my $start = $offset + 4 ) <= $limit ) {
		my ( $key, $size ) = unpack( "\@$offset n2", $rdata );
		last if ( $offset = $start + $size ) > $limit;
		push @$params, ( $key, substr $rdata, $start, $size );
	}
	die $self->type . ': corrupt RDATA' unless $offset == $limit;
	return;
}


sub _encode_rdata {			## encode rdata as wire-format octet string
	my $self = shift;

	return $self->{rdata} if $self->{rdata};
	my @packed = pack 'n a*', $self->{SvcPriority}, $self->{TargetName}->encode;
	my $params = $self->{SvcParams} || [];
	my @params = @$params;
	while (@params) {
		my $key = shift @params;
		my $val = shift @params;
		push @packed, pack( 'n2a*', $key, length($val), $val );
	}
	return join '', @packed;
}


sub _format_rdata {			## format rdata portion of RR string.
	my $self = shift;

	my @rdata = unpack 'H4', pack 'n', $self->{SvcPriority};

	my $encode = $self->{TargetName}->encode();
	my $length = 2 + length $encode;
	my @target = grep {length} split /(\S{32})/, unpack 'H*', $encode;
	my $target = substr $self->{TargetName}->string, 0, 40;
	push @rdata, join '', shift(@target), "\t; $target\n" unless $target eq '.';
	push @rdata, @target;

	my $params = $self->{SvcParams} || [];
	my @params = @$params;
	while (@params) {
		my $key = shift @params;
		my $val = shift @params;
		push @rdata, "\n", unpack 'H4H4', pack( 'n2', $key, length $val );
		my @hex = grep {length} split /(\S{32})/, unpack 'H*', $val;
		push @rdata, shift @hex if @hex;
		push @rdata, "\t; key$key\n" unless $key < 16;
		push @rdata, @hex;
		$length += 4 + length $val;
	}
	if ( $self->{rdata} ) {
		if ( my $corrupt = substr $self->{rdata}, $length ) {
			my ( $hex, @hex ) = grep {length} split /(\S{32})/, unpack 'H*', $corrupt;
			push @rdata, "\n$hex\t; corrupt RDATA\n", @hex;
			$length += length $corrupt;
		}
	}
	return ( "\\# $length", @rdata );
}


sub _parse_rdata {			## populate RR from rdata in argument list
	my ( $self, @argument ) = @_;

	$self->svcpriority( shift @argument );
	$self->targetname( shift @argument );

	while ( local $_ = shift @argument ) {
		m/^([^=]+)(=?)(.*)$/;
		my $key = $1;
		my $val = length($3) ? $3 : $2 ? shift @argument : '';
		if (/^key\d+/) {
			$self->$key($val);
		} else {
			local $_ = $val;
			die <<'RIP' if /\\092[,\\]/;
SVCB:	Please use standard RFC1035 escapes
	RFC9460 double-escape insanity not implemented
RIP
			s/^"([^"]*)"$/$1/s;			# strip enclosing quotes
			s/\\,/\\044/g;				# disguise (RFC1035) escaped comma
			$self->$key( split /,/ );
		}
	}
	return;
}


sub _post_parse {			## parser post processing
	my $self = shift;

	my $paramref = $self->{SvcParams} || [];
	my %svcparam = scalar(@$paramref) ? @$paramref : return;

	$self->key0(undef);					# ruse to force sorting of SvcParams
	if ( defined $svcparam{0} ) {
		my %unique;
		foreach ( grep { !$unique{$_}++ } unpack 'n*', $svcparam{0} ) {
			die( $self->type . qq[: unexpected "key0" in mandatory list] ) if $unique{0};
			die( $self->type . qq[: duplicate "key$_" in mandatory list] ) if --$unique{$_};
			die( $self->type . qq[: mandatory "key$_" not present] ) unless defined $svcparam{$_};
		}
		$self->mandatory( keys %unique );		# restore mandatory key list
	}
	die( $self->type . qq[: expected alpn="..." not present] ) if defined( $svcparam{2} ) && !$svcparam{1};
	return;
}


sub _defaults {				## specify RR attribute default values
	my $self = shift;

	$self->_parse_rdata(qw(0 .));
	return;
}


sub svcpriority {
	my ( $self, @value ) = @_;				# uncoverable pod
	for (@value) { $self->{SvcPriority} = 0 + $_ }
	return $self->{SvcPriority};
}


sub targetname {
	my ( $self, @value ) = @_;				# uncoverable pod
	$self->{TargetName} = Net::DNS::DomainName->new(@value) if @value;
	my $target = $self->{TargetName} ? $self->{TargetName}->name : return;
	return $target unless $target eq '.';
	return $self->{SvcPriority} ? $self->owner : undef;
}


sub mandatory {				## mandatory=key1,port,...
	my ( $self, @value ) = @_;
	my @list = map { $keybyname{lc $_} || $_ } @value;
	my @keys = map { /(\d+)$/ ? $1 : die( $self->type . qq[: unexpected "$_"] ) } @list;
	return $self->_SvcParam( 0, _integer16( sort { $a <=> $b } @keys ) );
}

sub alpn {				## alpn=h3,h2,...
	my ( $self, @value ) = @_;
	return $self->_SvcParam( 1, _string(@value) );
}

sub no_default_alpn {			## no-default-alpn	(Boolean)
	my ( $self, @value ) = @_;				# uncoverable pod
	return $self->_SvcParam(2) if defined wantarray;
	return $self->_SvcParam( 2, _boolean(@value) );
}

sub port {				## port=1234
	my ( $self, @value ) = @_;
	return $self->_SvcParam( 3, map { _integer16($_) } @value );
}

sub ipv4hint {				## ipv4hint=192.0.2.1,...
	my ( $self, @value ) = @_;
	return $self->_SvcParam( 4, _address4(@value) );
}

sub ech {				## ech=base64
	my ( $self, @value ) = @_;
	return $self->_SvcParam( 5, map { _base64($_) } @value );
}

sub ipv6hint {				## ipv6hint=2001:DB8::1,...
	my ( $self, @value ) = @_;
	return $self->_SvcParam( 6, _address6(@value) );
}

sub dohpath {				## dohpath=/dns-query{?dns}
	my ( $self, @value ) = @_;				# uncoverable pod
	return $self->_SvcParam( 7, map { substr _string($_), 1 } @value );
}

sub ohttp {				## ohttp
	my ( $self, @value ) = @_;				# uncoverable pod
	return $self->_SvcParam(8) if defined wantarray;
	return $self->_SvcParam( 8, _boolean(@value) );
}

sub tls_supported_groups {		## tls_supported_groups=29,23
	my ( $self, @value ) = @_;				# uncoverable pod
	return $self->_SvcParam( 9, _integer16(@value) );
}


########################################


sub _concatenate {			## concatenate octet string(s)
	my @arg = @_;
	return scalar(@arg) ? join( '', @arg ) : @arg;
}

sub _boolean {
	my @arg = @_;
	return '' unless scalar @arg;
	return map { $_ ? '' : undef } @arg;
}

sub _string {
	my @arg = @_;
	my @val = map { split /,/ } @arg;
	return _concatenate( map { Net::DNS::Text->new($_)->encode() } @val );
}

sub _base64 {
	my @arg = @_;
	return _concatenate( map { MIME::Base64::decode($_) } @arg );
}

sub _integer16 {
	my @arg = @_;
	my @val = map { split /,/ } @arg;
	return _concatenate( map { pack( 'n', $_ ) } @val );
}

sub _address4 {
	my @arg = @_;
	my @val = map { split /,/ } @arg;
	return _concatenate( map { Net::DNS::RR::A::address( {}, $_ ) } @val );
}

sub _address6 {
	my @arg = @_;
	my @val = map { split /,/ } @arg;
	return _concatenate( map { Net::DNS::RR::AAAA::address( {}, $_ ) } @val );
}


sub AUTOLOAD {				## Dynamic constructor/accessor methods
	my ( $self, @argument ) = @_;

	our $AUTOLOAD;
	my ($method)  = reverse split /::/, $AUTOLOAD;
	my $canonical = lc($method);
	$canonical =~ s/-/_/g;
	if ( $self->can($canonical) ) {
		no strict 'refs';	## no critic ProhibitNoStrict
		*{$AUTOLOAD} = sub { shift->$canonical(@_) };
		return $self->$canonical(@argument);
	}

	my $super = "SUPER::$method";
	return $self->$super(@argument) unless $method =~ /^key[0]*(\d+)$/i;
	my $key = $1;

	return $self->_SvcParam($key) unless @argument;
	my $first = shift @argument;
	my $value = defined $first ? Net::DNS::Text->new($first)->raw : $first;
	return $self->_SvcParam( $key, $value, @argument );
}


sub _SvcParam {
	my ( $self, $key, @argument ) = @_;

	my $paramsref = $self->{SvcParams} || [];
	my %svcparams = @$paramsref;

	if ( scalar @argument ) {
		my $arg = shift @argument;			# keyNN($value);
		delete $svcparams{$key} unless defined $arg;
		die( $self->type . qq[: duplicate SvcParam "key$key"] ) if defined $svcparams{$key};
		die( $self->type . qq[: invalid SvcParam "key$key"] )	if $key > 65534;
		die( $self->type . qq[: unexpected "key$key" value] )	if scalar @argument;
		delete $self->{rdata};
		$svcparams{$key} = $arg if defined $arg;
		$self->{SvcParams} = [map { ( $_, $svcparams{$_} ) } sort { $a <=> $b } keys %svcparams];
	} else {
		die( $self->type . qq[: no value specified for "key$key"] ) unless defined wantarray;
	}

	return $svcparams{$key};
}

########################################


1;
__END__