File Coverage

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

Criterion	Covered	Total	%
statement	105	105	100.0
branch	38	38	100.0
condition	12	12	100.0
subroutine	22	22	100.0
pod	8	8	100.0
total	185	185	100.0

package Net::DNS::RR::DS;

use strict;
use warnings;
our $VERSION = (qw$Id: DS.pm 2042 2025-12-24 10:23:11Z willem $)[2];

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


=head1 NAME

Net::DNS::RR::DS - DNS DS resource record

=cut

use integer;

use Carp;

use constant BABBLE => defined eval { require Digest::BubbleBabble };

eval { require Digest::SHA };		## optional for simple Net::DNS RR

my %digest = (
	'1' => ['Digest::SHA', 1],
	'2' => ['Digest::SHA', 256],
	'4' => ['Digest::SHA', 384],
	'6' => ['Net::DNS::SEC::Digest::SM3'],
	);


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

	my $rdata = substr $$data, $offset, $self->{rdlength};
	@{$self}{qw(keytag algorithm digtype digestbin)} = unpack 'n C2 a*', $rdata;
	return;
}


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

	return pack 'n C2 a*', @{$self}{qw(keytag algorithm digtype digestbin)};
}


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

	my @rdata = @{$self}{qw(keytag algorithm digtype)};
	if ( my $digest = $self->digest ) {
		$self->_annotation( $self->babble ) if BABBLE;
		push @rdata, split /(\S{64})/, $digest;
	} else {
		push @rdata, '""';
	}
	return @rdata;
}


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

	$self->keytag( shift @argument );
	my $algorithm = shift @argument;
	$self->digtype( shift @argument );
	$self->digest(@argument);
	$self->algorithm($algorithm);
	return;
}


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


sub algorithm {
	my ( $self, $arg ) = @_;

	unless ( ref($self) ) {		## class method or simple function
		my $argn = pop;
		return $argn =~ /[^0-9]/ ? _algbyname($argn) : _algbyval($argn);
	}

	return $self->{algorithm} unless defined $arg;
	return _algbyval( $self->{algorithm} ) if uc($arg) eq 'MNEMONIC';
	return $self->{algorithm} = _algbyname($arg) || die _algbyname('')    # disallow algorithm(0)
}


sub digtype {
	my ( $self, $arg ) = @_;

	unless ( ref($self) ) {		## class method or simple function
		my $argn = pop;
		return $argn =~ /[^0-9]/ ? _digestbyname($argn) : _digestbyval($argn);
	}

	return $self->{digtype} unless defined $arg;
	return _digestbyval( $self->{digtype} ) if uc($arg) eq 'MNEMONIC';
	return $self->{digtype} = _digestbyname($arg) || die _digestbyname('')	  # disallow digtype(0)
}


sub digest {
	my ( $self, @value ) = @_;
	return unpack "H*", $self->digestbin() unless scalar @value;
	my @hex = map { /^"*([\dA-Fa-f]*)"*$/ || croak("corrupt hex"); $1 } @value;
	return $self->digestbin( pack "H*", join "", @hex );
}


sub digestbin {
	my ( $self, @value ) = @_;
	for (@value) { $self->{digestbin} = $_ }
	return $self->{digestbin} || "";
}


sub babble {
	return BABBLE ? Digest::BubbleBabble::bubblebabble( Digest => shift->digestbin ) : '';
}


sub create {
	my ( $class, $keyrr, %args ) = @_;
	my ($type) = reverse split '::', $class;

	croak "Unable to create $type record for invalid key" unless $keyrr->protocol == 3;
	croak "Unable to create $type record for revoked key" if $keyrr->revoke;
	croak "Unable to create $type record for non-zone key" unless $keyrr->zone;

	my $self = Net::DNS::RR->new(
		owner	=> $keyrr->owner,			# per definition, same as keyrr
		type	=> $type,
		class	=> $keyrr->class,
		ttl	=> $keyrr->{ttl},
		digtype => 1,					# SHA1 by default
		%args,
		algorithm => $keyrr->algorithm,
		keytag	  => $keyrr->keytag
		);

	my $spec = $digest{$self->digtype};
	my $hash = eval {
		my ( $object, @param ) = @$spec;
		$object->new(@param);
	};
	croak join ' ', 'digtype', $self->digtype('MNEMONIC'), 'not supported' unless $hash;
	$hash->add( $keyrr->{owner}->canonical );
	$hash->add( $keyrr->_encode_rdata );
	$self->digestbin( $hash->digest );

	return $self;
}


sub verify {
	my ( $self, $key ) = @_;
	my $verify = Net::DNS::RR::DS->create( $key, ( digtype => $self->digtype ) );
	return $verify->digestbin eq $self->digestbin;
}


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

{
	my @digestbyname = (
		'SHA-1'		    => 1,			# [RFC3658]
		'SHA-256'	    => 2,			# [RFC4509]
		'GOST-R-34.11-94'   => 3,			# [RFC5933]
		'SHA-384'	    => 4,			# [RFC6605]
		'GOST-R-34.11-2012' => 5,			# [RFC9558]
		'SM3'		    => 6,			# [RFC9563]
		);

	my @digestalias = ( 'SHA' => 1 );

	my %digestbyval = reverse @digestbyname;

	foreach (@digestbyname) { s/[\W_]//g; }			# strip non-alphanumerics
	my @digestrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @digestbyname;
	my %digestbyname = ( @digestalias, @digestrehash );	# work around broken cperl

	sub _digestbyname {
		my $arg = shift;
		my $key = uc $arg;				# synthetic key
		$key =~ s/[\W_]//g;				# strip non-alphanumerics
		my $val = $digestbyname{$key};
		return $val if defined $val;
		return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg];
	}

	sub _digestbyval {
		my $value = shift;
		return $digestbyval{$value} || return $value;
	}
}


{
	my @algbyname = (
		'DELETE'	     => 0,			# [RFC4034][RFC4398][RFC8078]
		'RSAMD5'	     => 1,			# [RFC3110][RFC4034]
		'DH'		     => 2,			# [RFC2539]
		'DSA'		     => 3,			# [RFC3755][RFC2536]
					## Reserved	=> 4,	# [RFC6725]
		'RSASHA1'	     => 5,			# [RFC3110][RFC4034]
		'DSA-NSEC3-SHA1'     => 6,			# [RFC5155]
		'RSASHA1-NSEC3-SHA1' => 7,			# [RFC5155]
		'RSASHA256'	     => 8,			# [RFC5702]
					## Reserved	=> 9,	# [RFC6725]
		'RSASHA512'	     => 10,			# [RFC5702]
					## Reserved	=> 11,	# [RFC6725]
		'ECC-GOST'	     => 12,			# [RFC5933]
		'ECDSAP256SHA256'    => 13,			# [RFC6605]
		'ECDSAP384SHA384'    => 14,			# [RFC6605]
		'ED25519'	     => 15,			# [RFC8080]
		'ED448'		     => 16,			# [RFC8080]
		'SM2SM3'	     => 17,			# [RFC9563]
		'ECC-GOST12'	     => 23,			# [RFC9558]

		'INDIRECT'   => 252,				# [RFC4034]
		'PRIVATEDNS' => 253,				# [RFC4034]
		'PRIVATEOID' => 254,				# [RFC4034]
					## Reserved	=> 255,	# [RFC4034]
		);

	my %algbyval = reverse @algbyname;

	foreach (@algbyname) { s/[\W_]//g; }			# strip non-alphanumerics
	my @algrehash = map { /^\d/ ? ($_) x 3 : uc($_) } @algbyname;
	my %algbyname = @algrehash;				# work around broken cperl

	sub _algbyname {
		my $arg = shift;
		my $key = uc $arg;				# synthetic key
		$key =~ s/[\W_]//g;				# strip non-alphanumerics
		my $val = $algbyname{$key};
		return $val if defined $val;
		return $key =~ /^\d/ ? $arg : croak qq[unknown algorithm $arg];
	}

	sub _algbyval {
		my $value = shift;
		return $algbyval{$value} || return $value;
	}
}

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


1;
__END__