File Coverage

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

Criterion	Covered	Total	%
statement	123	123	100.0
branch	30	30	100.0
condition	8	8	100.0
subroutine	31	31	100.0
pod	8	10	100.0
total	200	202	100.0

package Net::DNS::RR::LOC;

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

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


=head1 NAME

Net::DNS::RR::LOC - DNS LOC resource record

=cut

use integer;

use Carp;


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

	my $version = $self->{version} = unpack "\@$offset C", $$data;
	@{$self}{qw(size hp vp latitude longitude altitude)} = unpack "\@$offset xC3N3", $$data;
	return;
}


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

	return pack 'C4N3', @{$self}{qw(version size hp vp latitude longitude altitude)};
}


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

	my ( $altitude, @precision ) = map { $self->$_() . 'm' } qw(altitude size hp vp);
	my $precision = join ' ', @precision;
	for ($precision) {
		s/^1m 10000m 10m$//;
		s/ 10000m 10m$//;
		s/ 10m$//;
	}
	return ( $self->latitude, '', $self->longitude, '', $altitude, $precision );
}


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

	my @lat;
	while ( scalar @argument ) {
		my $this = shift @argument;
		push( @lat, $this );
		last if $this =~ /[NSns]/;
	}
	$self->latitude(@lat);

	my @long;
	while ( scalar @argument ) {
		my $this = shift @argument;
		push( @long, $this );
		last if $this =~ /[EWew]/;
	}
	$self->longitude(@long);

	foreach my $attr (qw(altitude size hp vp)) {
		$self->$attr(@argument);
		shift @argument;
	}
	return;
}


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

	$self->{version} = 0;
	$self->size(1);
	$self->hp(10000);
	$self->vp(10);
	return;
}


sub latitude {
	my ( $self, @value ) = @_;
	$self->{latitude} = _encode_angle(@value) if scalar @value;
	return _decode_angle( $self->{latitude} || return, 'N', 'S' );
}


sub longitude {
	my ( $self, @value ) = @_;
	$self->{longitude} = _encode_angle(@value) if scalar @value;
	return _decode_angle( $self->{longitude} || return, 'E', 'W' );
}


sub altitude {
	my ( $self, @value ) = @_;
	$self->{altitude} = _encode_alt(@value) if scalar @value;
	return _decode_alt( $self->{altitude} );
}


sub size {
	my ( $self, @value ) = @_;
	$self->{size} = _encode_prec(@value) if scalar @value;
	return _decode_prec( $self->{size} );
}


sub hp {
	my ( $self, @value ) = @_;
	$self->{hp} = _encode_prec(@value) if scalar @value;
	return _decode_prec( $self->{hp} );
}

sub horiz_pre { return &hp; }					# uncoverable pod


sub vp {
	my ( $self, @value ) = @_;
	$self->{vp} = _encode_prec(@value) if scalar @value;
	return _decode_prec( $self->{vp} );
}

sub vert_pre { return &vp; }					# uncoverable pod


sub latlon {
	my ( $self, @argument ) = @_;
	my @lat = @argument;
	my ( undef, @long ) = @argument;
	return ( scalar $self->latitude(@lat), scalar $self->longitude(@long) );
}


sub version {
	return shift->{version};
}


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

no integer;

use constant ALTITUDE0 => 10000000;
use constant ORDINATE0 => 0x80000000;

sub _decode_angle {
	my ( $msec, $N, $S ) = @_;
	return int( 0.5 + ( $msec - ORDINATE0 ) / 0.36 ) / 10000000 unless wantarray;
	use integer;
	my $abs = abs( $msec - ORDINATE0 );
	my $deg = int( $abs / 3600000 );
	my $min = int( $abs / 60000 ) % 60;
	no integer;
	my $sec = ( $abs % 60000 ) / 1000;
	return ( $deg, $min, $sec, ( $msec < ORDINATE0 ? $S : $N ) );
}


sub _encode_angle {
	my @ang = @_;
	@ang = split /[\s\260'"]+/, shift @ang unless scalar @ang > 1;
	my $ang = ( 0 + shift @ang ) * 3600000;
	my $neg = ( @ang ? pop @ang : '' ) =~ /[SWsw]/;
	$ang += ( @ang ? shift @ang : 0 ) * 60000;
	$ang += ( @ang ? shift @ang : 0 ) * 1000;
	return int( 0.5 + ( $neg ? ORDINATE0 - $ang : ORDINATE0 + $ang ) );
}


sub _decode_alt {
	my $cm = ( shift || ALTITUDE0 ) - ALTITUDE0;
	return 0.01 * $cm;
}


sub _encode_alt {
	( my $argument = shift ) =~ s/[Mm]$//;
	$argument += 0;
	return int( 0.5 + ALTITUDE0 + 100 * $argument );
}


my @power10 = ( 0.01, 0.1, 1, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 0, 0, 0, 0, 0 );

sub _decode_prec {
	my $argument = shift || 0;
	my $mantissa = $argument >> 4;
	return $mantissa * $power10[$argument & 0x0F];
}

sub _encode_prec {
	( my $argument = shift ) =~ s/[Mm]$//;
	my $exponent = 0;
	until ( $argument < $power10[1 + $exponent] ) { $exponent++ }
	my $mantissa = int( 0.5 + $argument / $power10[$exponent] );
	return ( $mantissa & 0xF ) << 4 | $exponent;
}

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


1;
__END__