File Coverage

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

Criterion	Covered	Total	%
statement	285	285	100.0
branch	98	98	100.0
condition	32	32	100.0
subroutine	54	54	100.0
pod	11	14	100.0
total	480	483	100.0

package Net::DNS::RR::OPT;

use strict;
use warnings;
our $VERSION = (qw$Id: OPT.pm 1934 2023-08-25 12:14:08Z willem $)[2];

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


=head1 NAME

Net::DNS::RR::OPT - DNS OPT resource record

=cut

use integer;

use Carp;
use Net::DNS::Parameters qw(:rcode :ednsoption);

use constant UTIL => scalar eval { require Scalar::Util; Scalar::Util->can('isdual') };

use constant OPT => Net::DNS::Parameters::typebyname qw(OPT);

require Net::DNS::DomainName;
require Net::DNS::RR::A;
require Net::DNS::RR::AAAA;
require Net::DNS::Text;


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

	my $class = delete $self->{class};			# OPT redefines CLASS and TTL fields
	$self->udpsize($class) if defined $class;

	my $ttl = delete $self->{ttl};
	$self->_ttl($ttl) if defined $ttl;

	my $limit = $offset + $self->{rdlength} - 4;
	my @index;
	eval {
		while ( $offset <= $limit ) {
			my ( $code, $length ) = unpack "\@$offset nn", $$data;
			my $value = unpack "\@$offset x4 a$length", $$data;
			$self->{option}{$code} = $value;
			push @index, $code;
			$offset += $length + 4;
		}
	};
	@{$self->{index}} = @index;
	return;
}


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

	my $option = $self->{option} || {};
	return join '', map { pack( 'nna*', $_, length $option->{$_}, $option->{$_} ) } $self->options;
}


sub encode {				## override RR method
	my $self = shift;
	my $data = $self->_encode_rdata;
	return pack 'C n n N na*', 0, OPT, $self->udpsize, $self->_ttl, length($data), $data;
}


sub string {				## override RR method
	my @line = split /[\r\n]+/, shift->json;
	return join '', map {";;$_\n"} @line;
}

sub class {				## override RR method
	my ( $self, @value ) = @_;
	$self->_deprecate(qq[please use "UDPsize()"]);
	return $self->udpsize(@value);
}

sub ttl {				## override RR method
	my ( $self, @value ) = @_;
	$self->_deprecate(qq[please use "flags()", "rcode()" or "version()"]);
	return $self->_ttl(@value);
}

sub _ttl {
	my ( $self, @value ) = @_;
	for (@value) {
		@{$self}{qw(rcode version flags)} = unpack 'C2n', pack( 'N', $_ );
		$self->{rcode} = $self->{rcode} << 4;
		return;
	}
	return unpack 'N', pack( 'C2n', $self->rcode >> 4, $self->version, $self->flags );
}

sub generic {				## override RR method
	my $self = shift;
	local $self->{class} = $self->udpsize;
	my @xttl = ( $self->rcode >> 4, $self->version, $self->flags );
	local $self->{ttl} = unpack 'N', pack( 'C2n', @xttl );
	return $self->SUPER::generic;
}

sub token {				## override RR method
	return grep { !m/^[()]$/ } split /\s+/, &generic;
}

sub json {
	my $self = shift;					# uncoverable pod

	my $version = $self->version;
	unless ( $version == 0 ) {
		my $content = unpack 'H*', $self->encode;
		return <<"QQ";
 {	"EDNS-VERSION":	$version,
	"BASE16":	"$content"
	}
QQ
	}

	my $flags  = sprintf '%04x', $self->flags;
	my $rcode  = $self->rcode;
	my $size   = $self->udpsize;
	my @format = map { join( "\n\t\t\t", $self->_format_option($_) ) } $self->options;
	my @indent = scalar(@format) ? "\n\t\t" : ();
	my @option = join ",\n\t\t", @format;

	return <<"QQ";
 {	"EDNS-VERSION":	$version,
	"FLAGS":	"$flags",
	"RCODE":	$rcode,
	"UDPSIZE":	$size,
	"OPTIONS":	[@indent@option ]
	}
QQ
}


sub version {
	my ( $self, @value ) = @_;
	for (@value) { $self->{version} = 0 + $_ }
	return $self->{version} || 0;
}


sub udpsize {
	my ( $self, @value ) = @_;				# uncoverable pod
	for (@value) { $self->{udpsize} = ( $_ > 512 ) ? $_ : 0 }
	return $self->{udpsize} || 0;
}

sub size {
	my ( $self, @value ) = @_;				# uncoverable pod
	$self->_deprecate(qq[size() is an alias of "UDPsize()"]);
	return $self->udpsize(@value);
}


sub rcode {
	my ( $self, @value ) = @_;
	for (@value) { $self->{rcode} = ( $_ < 16 ) ? 0 : $_ }	# discard non-EDNS rcodes 1 .. 15
	return $self->{rcode} || 0;
}


sub flags {
	my ( $self, @value ) = @_;
	for (@value) { $self->{flags} = 0 + $_ }
	return $self->{flags} || 0;
}


sub options {
	my $self   = shift;
	my $option = $self->{option} || {};
	my @option = defined( $self->{index} ) ? @{$self->{index}} : sort { $a <=> $b } keys %$option;
	return @option;
}

sub option {
	my ( $self, $name, @value ) = @_;
	my $number = ednsoptionbyname($name);
	return $self->_get_option($number) unless scalar @value;
	my $value = $self->_set_option( $number, @value );
	return $@ ? croak( ( split /\sat/i, $@ )[0] ) : $value;
}


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

sub _get_option {
	my ( $self, $number ) = @_;

	my $options = $self->{option} || {};
	my $payload = $options->{$number};
	return $payload unless wantarray;
	my $package = join '::', __PACKAGE__, ednsoptionbyval($number);
	$package =~ s/-/_/g;
	if ( $package->can('_decompose') ) {
		return {'OPTION-LENGTH' => 0} unless length $payload;
		my @structure = eval { $package->_decompose($payload) };
		return @structure if scalar @structure;
	}
	warn $@ if $@;
	return length($payload) ? {BASE16 => unpack 'H*', $payload} : '';
}


sub _set_option {
	my ( $self, $number, @value ) = @_;
	my ($arg) = @value;

	my $options = $self->{option} || {};
	delete $options->{$number};
	delete $self->{option} unless scalar( keys %$options );

	return unless defined $arg;
	$self->{option} = $options;

	if ( ref($arg) eq 'HASH' ) {
		for ( keys %$arg ) { $$arg{uc $_} = $$arg{$_} } # tolerate mixed case
		my $length = $$arg{'OPTION-LENGTH'};
		my $octets = $$arg{'OPTION-DATA'};
		$octets = pack 'H*', $$arg{'BASE16'} if defined $$arg{'BASE16'};
		$octets = '' if defined($length) && $length == 0;
		return $options->{$number} = $octets if defined $octets;
	}

	my $option  = ednsoptionbyval($number);
	my $package = join '::', __PACKAGE__, $option;
	$package =~ s/-/_/g;
	return eval { $options->{$number} = $package->_compose(@value) } if length($arg) && $package->can('_compose');

	croak "unable to compose option $number" if ref($arg);
	return $options->{$number} = $arg;
}


sub _specified {
	my $self = shift;
	return scalar grep { $self->{$_} } qw(udpsize flags rcode option);
}


sub _format_option {
	my ( $self, $number ) = @_;
	my $option = ednsoptionbyval($number);
	my ($content) = $self->_get_option($number);
	return Net::DNS::RR::_wrap( _JSONify( {$option => $content} ) );
}


sub _JSONify {
	my $value = shift;
	return 'null' unless defined $value;

	if ( ref($value) eq 'HASH' ) {
		my @tags = sort keys %$value;
		my $tail = pop @tags;
		for ( $$value{BASE16} ) { $_ = pack( 'U0a*', $_ ) if defined }	  # mark as UTF-8
		my @body = map { my @x = ( qq("$_":), _JSONify( $$value{$_} ) ); $x[-1] .= ','; @x } @tags;
		push @body, ( qq("$tail":), _JSONify( $$value{$tail} ) );
		$body[0] = '{' . $body[0];
		$body[-1] .= '}';
		return @body;
	}

	if ( ref($value) eq 'ARRAY' ) {
		my @array = @$value;
		my @tail  = map { _JSONify($_) } grep {defined} pop @array;
		my @body  = map { my @x = _JSONify($_); $x[-1] .= ','; @x } @array;
		return ( '[', @body, @tail, ']' );
	}

	my $string = "$value";		## stringify, then use isdual() as discriminant
	return $string if UTIL && Scalar::Util::isdual($value); # native numeric representation
	for ($string) {
		unless ( utf8::is_utf8($value) ) {
			return $_ if /^-?\d+$/;			# integer (string representation)
			return $_ if /^-?\d+\.\d+$/;		# non-integer
			return $_ if /^-?\d+(\.\d+)?e[+-]\d\d?$/i;
		}
		s/\\/\\\\/g;					# escaped escape
		s/^"(.*)"$/$1/;					# strip enclosing quotes
		s/"/\\"/g;					# escape interior quotes
	}
	return qq("$string");
}


## no critic ProhibitMultiplePackages
package Net::DNS::RR::OPT::NSID;				# RFC5001

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_;
	return pack 'H*', pop @argument;
}

sub _decompose { return pack 'U0a*', unpack 'H*', pop @_ }	# mark as UTF-8


package Net::DNS::RR::OPT::DAU;					# RFC6975

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? @$_ : $_ } @_;
	return pack 'C*', @argument;
}

sub _decompose { return [unpack 'C*', pop @_] }


package Net::DNS::RR::OPT::DHU;					# RFC6975
our @ISA = qw(Net::DNS::RR::OPT::DAU);

package Net::DNS::RR::OPT::N3U;					# RFC6975
our @ISA = qw(Net::DNS::RR::OPT::DAU);


package Net::DNS::RR::OPT::CLIENT_SUBNET;			# RFC7871

my %family = qw(1 Net::DNS::RR::A	2 Net::DNS::RR::AAAA);
my @field8 = qw(FAMILY SOURCE-PREFIX SCOPE-PREFIX ADDRESS);

sub _compose {
	shift @_;
	my %argument = ( map( ( $_ => 0 ), @field8 ), map { ref($_) ? %$_ : $_ } @_ );
	my $family   = $family{$argument{FAMILY}} || die 'unrecognised address family';
	my $bitmask  = $argument{'SOURCE-PREFIX'};
	my $address  = bless( {}, $family )->address( $argument{ADDRESS} );
	return pack 'a* B*', pack( 'nC2', @argument{@field8} ), unpack "B$bitmask", $address;
}

sub _decompose {
	my %object;
	@object{@field8} = unpack 'nC2a*', pop @_;
	my $family = $family{$object{FAMILY}} || die 'unrecognised address family';
	for ( $object{ADDRESS} ) {
		$_ = bless( {address => $_}, $family )->address;
		s/:[:0]+$/::/;
	}
	return \%object;
}


package Net::DNS::RR::OPT::EXPIRE;				# RFC7314

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_;
	return pack 'N', pop @argument;
}

sub _decompose {
	my $argument = pop @_;
	return {'EXPIRE-TIMER' => unpack 'N', $argument};
}


package Net::DNS::RR::OPT::COOKIE;				# RFC7873

my @field10 = qw(CLIENT SERVER);

sub _compose {
	my ( undef, @argument ) = @_;
	for ( ref( $argument[0] ) ) {
		/HASH/	&& ( @argument = @{$argument[0]}{@field10} );
		/ARRAY/ && ( @argument = @{$argument[0]} );
	}
	return pack 'a8a*', map { pack 'H*', $_ || '' } @argument;
}

sub _decompose {
	my %object;
	@object{@field10} = map { pack 'U0a*', $_ } unpack 'H16H*', pop @_;    # mark as UTF-8
	return \%object;
}


package Net::DNS::RR::OPT::TCP_KEEPALIVE;			# RFC7828

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_;
	return pack 'n', pop @argument;
}

sub _decompose {
	my $argument = pop @_;
	return {'TIMEOUT' => unpack 'n', $argument};
}


package Net::DNS::RR::OPT::PADDING;				# RFC7830

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_;
	my $length = pop(@argument) || 0;
	return pack "x$length";
}

sub _decompose {
	my $argument = pop @_;
	return {'OPTION-LENGTH' => length $argument} if $argument =~ /^\000*$/;
	return {'BASE16'	=> unpack 'H*', $argument};
}


package Net::DNS::RR::OPT::CHAIN;				# RFC7901

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_;
	return Net::DNS::DomainName->new( pop @argument )->encode;
}

sub _decompose {
	my $argument = pop @_;
	return {'CLOSEST-TRUST-POINT' => Net::DNS::DomainName->decode( \$argument )->string};
}


package Net::DNS::RR::OPT::KEY_TAG;				# RFC8145

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? @$_ : $_ } @_;
	return pack 'n*', @argument;
}

sub _decompose { return [unpack 'n*', pop @_] }


package Net::DNS::RR::OPT::EXTENDED_ERROR;			# RFC8914

sub _compose {
	my ( undef, @arg ) = @_;
	my %arg	 = ref( $arg[0] ) ? %{$arg[0]} : @arg;
	my $text = join '', Net::DNS::RR::OPT::_JSONify( $arg{'EXTRA-TEXT'} || '' );
	return pack 'na*', $arg{'INFO-CODE'}, Net::DNS::Text->new($text)->raw;
}

sub _decompose {
	my ( $code, $text ) = unpack 'na*', pop @_;
	my $error = $Net::DNS::Parameters::dnserrorbyval{$code};
	my @error = defined($error) ? ( 'ERROR' => $error ) : ();
	my $extra = Net::DNS::Text->decode( \$text, 0, length $text );
	for ( $extra->value ) {
		last unless /^[\[\{]/;
		s/([\$\@])/\\$1/g;	## Here be dragons!
		my $REGEX = q/("[^"]*"|[\[\]{}:,]|[-0-9.Ee+]+)|\s+|(.)/;
		my @split = grep { defined && length } split /$REGEX/o;
		my $value = eval join( ' ', 'no integer;', map { s/^:$/=>/; $_ } @split );
		return {'INFO-CODE' => $code, @error, 'EXTRA-TEXT' => $value} if ref($value);
	}
	return {'INFO-CODE' => $code, @error, 'EXTRA-TEXT' => $extra->value};
}


package Net::DNS::RR::OPT::REPORT_CHANNEL;			# draft-ietf-dnsop-dns-error-reporting

sub _compose {
	my ( undef, @argument ) = map { ref($_) ? %$_ : $_ } @_;
	return Net::DNS::DomainName->new( pop @argument )->encode;
}

sub _decompose {
	my $argument = pop @_;
	return {'AGENT-DOMAIN' => Net::DNS::DomainName->decode( \$argument )->string};
}

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


1;
__END__