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


line stmt bran cond sub pod time code
1             package Net::DNS::RR::LOC;
2              
3 1     1   7 use strict;
  1         2  
  1         30  
4 1     1   8 use warnings;
  1         2  
  1         61  
5             our $VERSION = (qw$Id: LOC.pm 1896 2023-01-30 12:59:25Z willem $)[2];
6              
7 1     1   6 use base qw(Net::DNS::RR);
  1         2  
  1         148  
8              
9              
10             =head1 NAME
11              
12             Net::DNS::RR::LOC - DNS LOC resource record
13              
14             =cut
15              
16 1     1   7 use integer;
  1         4  
  1         5  
17              
18 1     1   35 use Carp;
  1         2  
  1         1088  
19              
20              
21             sub _decode_rdata { ## decode rdata from wire-format octet string
22 1     1   2 my ( $self, $data, $offset ) = @_;
23              
24 1         3 my $version = $self->{version} = unpack "\@$offset C", $$data;
25 1         4 @{$self}{qw(size hp vp latitude longitude altitude)} = unpack "\@$offset xC3N3", $$data;
  1         4  
26 1         2 return;
27             }
28              
29              
30             sub _encode_rdata { ## encode rdata as wire-format octet string
31 5     5   6 my $self = shift;
32              
33 5         10 return pack 'C4N3', @{$self}{qw(version size hp vp latitude longitude altitude)};
  5         20  
34             }
35              
36              
37             sub _format_rdata { ## format rdata portion of RR string.
38 2     2   3 my $self = shift;
39              
40 2         4 my ( $altitude, @precision ) = map { $self->$_() . 'm' } qw(altitude size hp vp);
  8         16  
41 2         5 my $precision = join ' ', @precision;
42 2         5 for ($precision) {
43 2         4 s/^1m 10000m 10m$//;
44 2         4 s/ 10000m 10m$//;
45 2         10 s/ 10m$//;
46             }
47 2         4 return ( $self->latitude, '', $self->longitude, '', $altitude, $precision );
48             }
49              
50              
51             sub _parse_rdata { ## populate RR from rdata in argument list
52 1     1   4 my ( $self, @argument ) = @_;
53              
54 1         3 my @lat;
55 1         11 while ( scalar @argument ) {
56 4         7 my $this = shift @argument;
57 4         5 push( @lat, $this );
58 4 100       15 last if $this =~ /[NSns]/;
59             }
60 1         4 $self->latitude(@lat);
61              
62 1         2 my @long;
63 1         3 while ( scalar @argument ) {
64 4         6 my $this = shift @argument;
65 4         7 push( @long, $this );
66 4 100       10 last if $this =~ /[EWew]/;
67             }
68 1         3 $self->longitude(@long);
69              
70 1         2 foreach my $attr (qw(altitude size hp vp)) {
71 4         11 $self->$attr(@argument);
72 4         6 shift @argument;
73             }
74 1         16 return;
75             }
76              
77              
78             sub _defaults { ## specify RR attribute default values
79 1     1   2 my $self = shift;
80              
81 1         6 $self->{version} = 0;
82 1         3 $self->size(1);
83 1         3 $self->hp(10000);
84 1         3 $self->vp(10);
85 1         2 return;
86             }
87              
88              
89             sub latitude {
90 8     8 1 20 my ( $self, @value ) = @_;
91 8 100       37 $self->{latitude} = _encode_angle(@value) if scalar @value;
92 8   100     29 return _decode_angle( $self->{latitude} || return, 'N', 'S' );
93             }
94              
95              
96             sub longitude {
97 8     8 1 1163 my ( $self, @value ) = @_;
98 8 100       18 $self->{longitude} = _encode_angle(@value) if scalar @value;
99 8   100     32 return _decode_angle( $self->{longitude} || return, 'E', 'W' );
100             }
101              
102              
103             sub altitude {
104 6     6 1 1061 my ( $self, @value ) = @_;
105 6 100       14 $self->{altitude} = _encode_alt(@value) if scalar @value;
106 6         17 return _decode_alt( $self->{altitude} );
107             }
108              
109              
110             sub size {
111 7     7 1 1040 my ( $self, @value ) = @_;
112 7 100       20 $self->{size} = _encode_prec(@value) if scalar @value;
113 7         17 return _decode_prec( $self->{size} );
114             }
115              
116              
117             sub hp {
118 9     9 1 1035 my ( $self, @value ) = @_;
119 9 100       21 $self->{hp} = _encode_prec(@value) if scalar @value;
120 9         18 return _decode_prec( $self->{hp} );
121             }
122              
123 2     2 0 637 sub horiz_pre { return &hp; } # uncoverable pod
124              
125              
126             sub vp {
127 9     9 1 1032 my ( $self, @value ) = @_;
128 9 100       21 $self->{vp} = _encode_prec(@value) if scalar @value;
129 9         17 return _decode_prec( $self->{vp} );
130             }
131              
132 2     2 0 668 sub vert_pre { return &vp; } # uncoverable pod
133              
134              
135             sub latlon {
136 2     2 1 700 my ( $self, @argument ) = @_;
137 2         4 my @lat = @argument;
138 2         4 my ( undef, @long ) = @argument;
139 2         3 return ( scalar $self->latitude(@lat), scalar $self->longitude(@long) );
140             }
141              
142              
143             sub version {
144 2     2 1 647 return shift->{version};
145             }
146              
147              
148             ########################################
149              
150 1     1   8 no integer;
  1         4  
  1         5  
151              
152 1     1   29 use constant ALTITUDE0 => 10000000;
  1         2  
  1         109  
153 1     1   7 use constant ORDINATE0 => 0x80000000;
  1         2  
  1         93  
154              
155             sub _decode_angle {
156 14     14   29 my ( $msec, $N, $S ) = @_;
157 14 100       56 return int( 0.5 + ( $msec - ORDINATE0 ) / 0.36 ) / 10000000 unless wantarray;
158 1     1   7 use integer;
  1         2  
  1         4  
159 4         15 my $abs = abs( $msec - ORDINATE0 );
160 4         8 my $deg = int( $abs / 3600000 );
161 4         5 my $min = int( $abs / 60000 ) % 60;
162 1     1   70 no integer;
  1         2  
  1         4  
163 4         7 my $sec = ( $abs % 60000 ) / 1000;
164 4 100       21 return ( $deg, $min, $sec, ( $msec < ORDINATE0 ? $S : $N ) );
165             }
166              
167              
168             sub _encode_angle {
169 4     4   10 my @ang = @_;
170 4 100       15 @ang = split /[\s\260'"]+/, shift @ang unless scalar @ang > 1;
171 4         13 my $ang = ( 0 + shift @ang ) * 3600000;
172 4 100       11 my $neg = ( @ang ? pop @ang : '' ) =~ /[SWsw]/;
173 4 100       11 $ang += ( @ang ? shift @ang : 0 ) * 60000;
174 4 100       13 $ang += ( @ang ? shift @ang : 0 ) * 1000;
175 4 100       15 return int( 0.5 + ( $neg ? ORDINATE0 - $ang : ORDINATE0 + $ang ) );
176             }
177              
178              
179             sub _decode_alt {
180 6   100 6   19 my $cm = ( shift || ALTITUDE0 ) - ALTITUDE0;
181 6         32 return 0.01 * $cm;
182             }
183              
184              
185             sub _encode_alt {
186 2     2   8 ( my $argument = shift ) =~ s/[Mm]$//;
187 2         5 $argument += 0;
188 2         6 return int( 0.5 + ALTITUDE0 + 100 * $argument );
189             }
190              
191              
192             my @power10 = ( 0.01, 0.1, 1, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7, 1e8, 0, 0, 0, 0, 0 );
193              
194             sub _decode_prec {
195 25   100 25   58 my $argument = shift || 0;
196 25         33 my $mantissa = $argument >> 4;
197 25         88 return $mantissa * $power10[$argument & 0x0F];
198             }
199              
200             sub _encode_prec {
201 8     8   22 ( my $argument = shift ) =~ s/[Mm]$//;
202 8         15 my $exponent = 0;
203 8         25 until ( $argument < $power10[1 + $exponent] ) { $exponent++ }
  30         51  
204 8         17 my $mantissa = int( 0.5 + $argument / $power10[$exponent] );
205 8         18 return ( $mantissa & 0xF ) << 4 | $exponent;
206             }
207              
208             ########################################
209              
210              
211             1;
212             __END__