File Coverage

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

Criterion	Covered	Total	%
statement	96	96	100.0
branch	20	20	100.0
condition	12	12	100.0
subroutine	17	17	100.0
pod	1	1	100.0
total	146	146	100.0

package Net::DNS::RR::APL;

use strict;
use warnings;
our $VERSION = (qw$Id: APL.pm 1896 2023-01-30 12:59:25Z willem $)[2];

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


=head1 NAME

Net::DNS::RR::APL - DNS APL resource record

=cut

use integer;

use Carp;


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

	my $limit = $offset + $self->{rdlength};

	my $aplist = $self->{aplist} = [];
	while ( $offset < $limit ) {
		my $xlen = unpack "\@$offset x3 C", $$data;
		my $size = ( $xlen & 0x7F );
		my $item = bless {}, 'Net::DNS::RR::APL::Item';
		$item->{negate} = $xlen - $size;
		@{$item}{qw(family prefix address)} = unpack "\@$offset n C x a$size", $$data;
		$offset += $size + 4;
		push @$aplist, $item;
	}
	croak('corrupt APL data') unless $offset == $limit;	# more or less FUBAR
	return;
}


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

	my @rdata;
	my $aplist = $self->{aplist};
	foreach (@$aplist) {
		my $address = $_->{address};
		$address =~ s/[\000]+$//;			# strip trailing null octets
		my $xlength = ( $_->{negate} ? 0x80 : 0 ) | length($address);
		push @rdata, pack 'n C2 a*', @{$_}{qw(family prefix)}, $xlength, $address;
	}
	return join '', @rdata;
}


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

	my $aplist = $self->{aplist};
	my @rdata  = map { $_->string } @$aplist;
	return @rdata;
}


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

	$self->aplist(@argument);
	return;
}


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

	while ( scalar @argument ) {				# parse apitem strings
		last unless $argument[0] =~ m#[!:./]#;
		local $_ = shift @argument;
		m#^(!?)(\d+):(.+)/(\d+)$#;
		my $n = $1 ? 1 : 0;
		my $f = $2 || 0;
		my $a = $3;
		my $p = $4 || 0;
		$self->aplist( negate => $n, family => $f, address => $a, prefix => $p );
	}

	my $aplist = $self->{aplist} ||= [];
	if ( my %argval = @argument ) {				# parse attribute=value list
		my $item = bless {}, 'Net::DNS::RR::APL::Item';
		while ( my ( $attribute, $value ) = each %argval ) {
			$item->$attribute($value) unless $attribute eq 'address';
		}
		$item->address( $argval{address} );		# address must be last
		push @$aplist, $item;
	}

	my @ap = @$aplist;
	return unless defined wantarray;
	return wantarray ? @ap : join ' ', map { $_->string } @ap;
}


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


package Net::DNS::RR::APL::Item;	## no critic ProhibitMultiplePackages

use Net::DNS::RR::A;
use Net::DNS::RR::AAAA;

my %family = qw(1 Net::DNS::RR::A	2 Net::DNS::RR::AAAA);


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


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


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


sub address {
	my ( $self, @value ) = @_;

	my $family = $family{$self->family} || die 'unknown address family';
	return bless( {%$self}, $family )->address unless scalar @value;

	my $bitmask = $self->prefix;
	my $address = bless( {}, $family )->address( shift @value );
	return $self->{address} = pack "B$bitmask", unpack 'B*', $address;
}


sub string {
	my $self = shift;

	my $not = $self->{negate} ? '!' : '';
	my ( $family, $address, $prefix ) = ( $self->family, $self->address, $self->prefix );
	return "$not$family:$address/$prefix";
}


1;
__END__