File Coverage

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

Criterion	Covered	Total	%
statement	127	127	100.0
branch	42	42	100.0
condition	14	14	100.0
subroutine	27	27	100.0
pod	14	14	100.0
total	224	224	100.0

package Net::DNS::RR::DNSKEY;

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

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


=head1 NAME

Net::DNS::RR::DNSKEY - DNS DNSKEY resource record

=cut

use integer;

use Carp;

use constant BASE64 => defined eval { require MIME::Base64 };


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

	my $rdata = substr $$data, $offset, $self->{rdlength};
	@{$self}{qw(flags protocol algorithm keybin)} = 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(flags protocol algorithm keybin)};
}


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

	my @rdata = @{$self}{qw(flags protocol algorithm)};
	if ( my $keybin = $self->keybin ) {
		$self->_annotation( 'keytag', $self->keytag );
		return $self->SUPER::_format_rdata() unless BASE64;
		push @rdata, split /\s+/, MIME::Base64::encode($keybin);
	} else {
		push @rdata, '""';
	}
	return @rdata;
}


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

	$self->flags( shift @argument );
	$self->protocol( shift @argument );
	my $algorithm = shift @argument;
	$self->key(@argument) if $algorithm;
	$self->algorithm($algorithm);
	return;
}


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

	$self->flags(256);
	$self->protocol(3);
	$self->algorithm(1);
	$self->keybin('');
	return;
}


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


sub zone {
	my ( $self, @value ) = @_;
	if ( scalar @value ) {
		for ( $self->{flags} |= 0x0100 ) {
			$_ ^= 0x0100 unless shift @value;
		}
	}
	return $self->{flags} & 0x0100;
}


sub revoke {
	my ( $self, @value ) = @_;
	if ( scalar @value ) {
		for ( $self->{flags} |= 0x0080 ) {
			$_ ^= 0x0080 unless shift @value;
		}
	}
	return $self->{flags} & 0x0080;
}


sub adt {
	my ( $self, @value ) = @_;
	if ( scalar @value ) {
		for ( $self->{flags} |= 0x0002 ) {
			$_ ^= 0x0002 unless shift @value;
		}
	}
	return $self->{flags} & 0x0002;
}


sub sep {
	my ( $self, @value ) = @_;
	if ( scalar @value ) {
		for ( $self->{flags} |= 0x0001 ) {
			$_ ^= 0x0001 unless shift @value;
		}
	}
	return $self->{flags} & 0x0001;
}


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


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

	unless ( ref($self) ) {		## class method or simple function
		my $argn = pop;
		return $argn =~ /\D/ ? _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 key {
	my ( $self, @value ) = @_;
	return MIME::Base64::encode( $self->keybin(), "" ) unless scalar @value;
	return $self->keybin( MIME::Base64::decode( join "", @value ) );
}


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


sub publickey {
	my ( $self, @value ) = @_;
	return $self->key(@value);
}


sub privatekeyname {
	my $self = shift;
	my $name = $self->signame;
	return sprintf 'K%s+%03d+%05d.private', $name, $self->algorithm, $self->keytag;
}


sub signame {
	my $self = shift;
	return lc $self->{owner}->fqdn;
}


sub keylength {
	my $self = shift;

	my $keybin = $self->keybin || return;

	local $_ = _algbyval( $self->{algorithm} );

	if (/^RSA/) {

		# Modulus length, see RFC 3110
		if ( my $exp_length = unpack 'C', $keybin ) {

			return ( length($keybin) - $exp_length - 1 ) << 3;

		} else {
			$exp_length = unpack 'x n', $keybin;
			return ( length($keybin) - $exp_length - 3 ) << 3;
		}

	} elsif (/^DSA/) {

		# Modulus length, see RFC 2536
		my $T = unpack 'C', $keybin;
		return ( $T << 6 ) + 512;
	}

	return length($keybin) << 2;	## ECDSA / EdDSA
}


sub keytag {
	my $self = shift;

	my $keybin = $self->{keybin} || return;

	# RFC4034 Appendix B.1: most significant 16 bits of least significant 24 bits
	return unpack 'n', substr $keybin, -3 if $self->{algorithm} == 1;

	# RFC4034 Appendix B
	my $od = length($keybin) & 1;
	my $rd = pack "n C2 a* x$od", @{$self}{qw(flags protocol algorithm)}, $keybin;
	my $ac = 0;
	$ac += $_ for unpack 'n*', $rd;
	$ac += ( $ac >> 16 );
	return $ac & 0xFFFF;
}


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

{
	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__