Initial Commit
This commit is contained in:
Riley Schneider
553
database/perl/vendor/lib/Net/DNS/RR/OPT.pm
vendored
Normal file
553
database/perl/vendor/lib/Net/DNS/RR/OPT.pm
vendored
Normal file
@@ -0,0 +1,553 @@
|
||||
package Net::DNS::RR::OPT;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
our $VERSION = (qw$Id: OPT.pm 1823 2020-11-16 16:29:45Z willem $)[2];
|
||||
|
||||
use base qw(Net::DNS::RR);
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Net::DNS::RR::OPT - DNS OPT resource record
|
||||
|
||||
=cut
|
||||
|
||||
use integer;
|
||||
|
||||
use Carp;
|
||||
use Net::DNS::Parameters qw(:rcode :ednsoption);
|
||||
|
||||
use constant CLASS_TTL_RDLENGTH => length pack 'n N n', (0) x 3;
|
||||
|
||||
use constant OPT => Net::DNS::Parameters::typebyname qw(OPT);
|
||||
|
||||
require Net::DNS::DomainName;
|
||||
require Net::DNS::RR::A;
|
||||
require Net::DNS::RR::AAAA;
|
||||
require Net::DNS::Text;
|
||||
|
||||
|
||||
sub _decode_rdata { ## decode rdata from wire-format octet string
|
||||
my $self = shift;
|
||||
my ( $data, $offset ) = @_;
|
||||
|
||||
my $index = $offset - CLASS_TTL_RDLENGTH; # OPT redefines class and TTL fields
|
||||
@{$self}{qw(size rcode version flags)} = unpack "\@$index n C2 n", $$data;
|
||||
@{$self}{rcode} = @{$self}{rcode} << 4;
|
||||
delete @{$self}{qw(class ttl)};
|
||||
|
||||
my $limit = $offset + $self->{rdlength} - 4;
|
||||
|
||||
while ( $offset <= $limit ) {
|
||||
my ( $code, $length ) = unpack "\@$offset nn", $$data;
|
||||
my $value = unpack "\@$offset x4 a$length", $$data;
|
||||
$self->{option}{$code} = $value;
|
||||
$offset += $length + 4;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
sub _encode_rdata { ## encode rdata as wire-format octet string
|
||||
my $self = shift;
|
||||
|
||||
my $option = $self->{option} || {};
|
||||
return join '', map { pack( 'nna*', $_, length $option->{$_}, $option->{$_} ) } keys %$option;
|
||||
}
|
||||
|
||||
|
||||
sub encode { ## overide RR method
|
||||
my $self = shift;
|
||||
|
||||
my $data = $self->_encode_rdata;
|
||||
my $size = $self->size;
|
||||
my @xttl = ( $self->rcode >> 4, $self->version, $self->flags );
|
||||
return pack 'C n n C2n n a*', 0, OPT, $size, @xttl, length($data), $data;
|
||||
}
|
||||
|
||||
|
||||
sub string { ## overide RR method
|
||||
my $self = shift;
|
||||
|
||||
my $edns = $self->version;
|
||||
my $flags = sprintf '%04x', $self->flags;
|
||||
my $rcode = $self->rcode;
|
||||
my $size = $self->size;
|
||||
my @option = map { join( "\n;;\t\t\t\t", $self->_format_option($_) ) } $self->options;
|
||||
my @format = join "\n;;\t\t", @option;
|
||||
|
||||
$rcode = 0 if $rcode < 16; # weird: 1 .. 15 not EDNS codes!!
|
||||
|
||||
my $rc = exists( $self->{rdlength} ) && $rcode ? "$rcode + [4-bits]" : rcodebyval($rcode);
|
||||
|
||||
$rc = 'BADVERS' if $rcode == 16; # code 16 unambiguous here
|
||||
|
||||
return <<"QQ";
|
||||
;; EDNS version $edns
|
||||
;; flags: $flags
|
||||
;; rcode: $rc
|
||||
;; size: $size
|
||||
;; option: @format
|
||||
QQ
|
||||
}
|
||||
|
||||
|
||||
sub class { ## overide RR method
|
||||
my $self = shift;
|
||||
$self->_deprecate(qq[please use "size()"]);
|
||||
return $self->size(@_);
|
||||
}
|
||||
|
||||
sub ttl { ## overide RR method
|
||||
my $self = shift;
|
||||
$self->_deprecate(qq[please use "flags()" or "rcode()"]);
|
||||
my @rcode = map { unpack( 'C', pack 'N', $_ ) } @_;
|
||||
my @flags = map { unpack( 'x2n', pack 'N', $_ ) } @_;
|
||||
return pack 'C2n', $self->rcode(@rcode), $self->version, $self->flags(@flags);
|
||||
}
|
||||
|
||||
|
||||
sub version {
|
||||
my $self = shift;
|
||||
|
||||
$self->{version} = 0 + shift if scalar @_;
|
||||
return $self->{version} || 0;
|
||||
}
|
||||
|
||||
|
||||
sub size {
|
||||
my $self = shift;
|
||||
$self->{size} = shift if scalar @_;
|
||||
return ( $self->{size} || 0 ) > 512 ? $self->{size} : 512;
|
||||
}
|
||||
|
||||
|
||||
sub rcode {
|
||||
my $self = shift;
|
||||
return $self->{rcode} || 0 unless scalar @_;
|
||||
delete $self->{rdlength}; # (ab)used to signal incomplete value
|
||||
my $val = shift || 0;
|
||||
return $self->{rcode} = $val < 16 ? 0 : $val; # discard non-EDNS rcodes 1 .. 15
|
||||
}
|
||||
|
||||
|
||||
sub flags {
|
||||
my $self = shift;
|
||||
$self->{flags} = shift if scalar @_;
|
||||
return $self->{flags} || 0;
|
||||
}
|
||||
|
||||
|
||||
sub options {
|
||||
my ($self) = @_;
|
||||
my $option = $self->{option} || {};
|
||||
my @option = sort { $a <=> $b } keys %$option;
|
||||
return @option;
|
||||
}
|
||||
|
||||
sub option {
|
||||
my $self = shift;
|
||||
my $number = ednsoptionbyname(shift);
|
||||
return $self->_get_option($number) unless scalar @_;
|
||||
return $self->_set_option( $number, @_ );
|
||||
}
|
||||
|
||||
|
||||
sub _format_option {
|
||||
my ( $self, $number ) = @_;
|
||||
my $option = ednsoptionbyval($number);
|
||||
my $options = $self->{option} || {};
|
||||
my $payload = $options->{$number};
|
||||
return () unless defined $payload;
|
||||
my $package = join '::', __PACKAGE__, $option;
|
||||
$package =~ s/-/_/g;
|
||||
my $defined = length($payload) && $package->can('_image');
|
||||
my @element = $defined ? eval { $package->_image($payload) } : unpack 'H*', $payload;
|
||||
my $protect = pop(@element);
|
||||
return Net::DNS::RR::_wrap( "$option\t=> (", map( {"$_,"} @element ), "$protect )" );
|
||||
}
|
||||
|
||||
|
||||
sub _get_option {
|
||||
my ( $self, $number ) = @_;
|
||||
|
||||
my $options = $self->{option} || {};
|
||||
my $payload = $options->{$number};
|
||||
return $payload unless wantarray;
|
||||
return () unless $payload;
|
||||
my $package = join '::', __PACKAGE__, ednsoptionbyval($number);
|
||||
$package =~ s/-/_/g;
|
||||
return ( 'OPTION-DATA' => $payload ) unless $package->can('_decompose');
|
||||
return eval { $package->_decompose($payload) };
|
||||
}
|
||||
|
||||
|
||||
sub _set_option {
|
||||
my ( $self, $number, $value, @etc ) = @_;
|
||||
|
||||
my $options = $self->{option} ||= {};
|
||||
delete $options->{$number};
|
||||
return unless defined $value;
|
||||
if ( ref($value) || scalar(@etc) || $value !~ /\D/ ) {
|
||||
my @arg = ( $value, @etc );
|
||||
@arg = @$value if ref($value) eq 'ARRAY';
|
||||
@arg = %$value if ref($value) eq 'HASH';
|
||||
if ( $arg[0] eq 'OPTION-DATA' ) {
|
||||
$value = $arg[1];
|
||||
} else {
|
||||
my $option = ednsoptionbyval($number);
|
||||
my $package = join '::', __PACKAGE__, $option;
|
||||
$package =~ s/-/_/g;
|
||||
if ( $package->can('_compose') ) {
|
||||
$value = $package->_compose(@arg);
|
||||
} elsif ( scalar(@etc) ) {
|
||||
croak "unable to compose option $option";
|
||||
}
|
||||
}
|
||||
}
|
||||
return $options->{$number} = $value;
|
||||
}
|
||||
|
||||
|
||||
sub _specified {
|
||||
my $self = shift;
|
||||
return scalar grep { $self->{$_} } qw(size flags rcode option);
|
||||
}
|
||||
|
||||
|
||||
########################################
|
||||
|
||||
## no critic ProhibitMultiplePackages
|
||||
package Net::DNS::RR::OPT::DAU; # RFC6975
|
||||
|
||||
sub _compose {
|
||||
shift;
|
||||
return pack 'C*', @_;
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my @payload = unpack 'C*', $_[1];
|
||||
return @payload;
|
||||
}
|
||||
|
||||
sub _image { return &_decompose; }
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::DHU; # RFC6975
|
||||
our @ISA = qw(Net::DNS::RR::OPT::DAU);
|
||||
|
||||
package Net::DNS::RR::OPT::N3U; # RFC6975
|
||||
our @ISA = qw(Net::DNS::RR::OPT::DAU);
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::CLIENT_SUBNET; # RFC7871
|
||||
|
||||
my %family = qw(0 Net::DNS::RR::AAAA 1 Net::DNS::RR::A 2 Net::DNS::RR::AAAA);
|
||||
my @field8 = qw(FAMILY SOURCE-PREFIX-LENGTH SCOPE-PREFIX-LENGTH ADDRESS);
|
||||
|
||||
sub _compose {
|
||||
my ( $class, %argument ) = ( map( ( $_ => 0 ), @field8 ), @_ );
|
||||
my $address = bless( {}, $family{$argument{FAMILY}} )->address( $argument{ADDRESS} );
|
||||
my $bitmask = $argument{'SOURCE-PREFIX-LENGTH'};
|
||||
pack "a* B$bitmask", pack( 'nC2', @argument{@field8} ), unpack 'B*', $address;
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my %hash;
|
||||
@hash{@field8} = unpack 'nC2a*', $_[1];
|
||||
$hash{ADDRESS} = bless( {address => $hash{ADDRESS}}, $family{$hash{FAMILY}} )->address;
|
||||
my @payload = map( ( $_ => $hash{$_} ), @field8 );
|
||||
}
|
||||
|
||||
sub _image {
|
||||
my %hash = &_decompose;
|
||||
my @image = map "$_ => $hash{$_}", @field8;
|
||||
}
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::EXPIRE; # RFC7314
|
||||
|
||||
sub _compose {
|
||||
my ( $class, %argument ) = @_;
|
||||
pack 'N', values %argument;
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my @payload = ( 'EXPIRE-TIMER' => unpack 'N', $_[1] );
|
||||
}
|
||||
|
||||
sub _image { join ' => ', &_decompose; }
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::COOKIE; # RFC7873
|
||||
|
||||
my @field10 = qw(VERSION RESERVED TIMESTAMP HASH);
|
||||
|
||||
sub _compose {
|
||||
my ( $class, %argument ) = ( VERSION => 1, RESERVED => '', @_ );
|
||||
return pack 'a8', $argument{'CLIENT-COOKIE'} if $argument{'CLIENT-COOKIE'};
|
||||
pack 'Ca3Na*', map $_, @argument{@field10};
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my ( $class, $argument ) = @_;
|
||||
return ( 'CLIENT-COOKIE', $argument ) unless length($argument) > 8;
|
||||
my %hash;
|
||||
@hash{@field10} = unpack 'Ca3Na*', $argument;
|
||||
my @payload = map( ( $_ => $hash{$_} ), @field10 );
|
||||
}
|
||||
|
||||
sub _image {
|
||||
my %hash = &_decompose;
|
||||
return unpack 'H*', $hash{'CLIENT-COOKIE'} if $hash{'CLIENT-COOKIE'};
|
||||
for (qw(RESERVED HASH)) { $hash{$_} = unpack 'H*', $hash{$_} }
|
||||
my @image = map "$_ => $hash{$_}", @field10;
|
||||
}
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::TCP_KEEPALIVE; # RFC7828
|
||||
|
||||
sub _compose {
|
||||
my ( $class, %argument ) = @_;
|
||||
pack 'n', values %argument;
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my @payload = ( 'TIMEOUT' => unpack 'n', $_[1] );
|
||||
}
|
||||
|
||||
sub _image { join ' => ', &_decompose; }
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::PADDING; # RFC7830
|
||||
|
||||
sub _compose {
|
||||
my ( $class, %argument ) = @_;
|
||||
my ($size) = values %argument;
|
||||
pack "x$size";
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my @payload = ( 'OPTION-LENGTH' => length( $_[1] ) );
|
||||
}
|
||||
|
||||
sub _image { join ' => ', &_decompose; }
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::CHAIN; # RFC7901
|
||||
|
||||
sub _compose {
|
||||
my ( $class, %argument ) = @_;
|
||||
my ($trust_point) = values %argument;
|
||||
Net::DNS::DomainName->new($trust_point)->encode;
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my ( $class, $payload ) = @_;
|
||||
my $fqdn = Net::DNS::DomainName->decode( \$payload )->string;
|
||||
my @payload = ( 'CLOSEST-TRUST-POINT' => $fqdn );
|
||||
}
|
||||
|
||||
sub _image { join ' => ', &_decompose; }
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::KEY_TAG; # RFC8145
|
||||
|
||||
sub _compose {
|
||||
shift;
|
||||
pack 'n*', @_;
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my @payload = unpack 'n*', $_[1];
|
||||
}
|
||||
|
||||
sub _image { &_decompose; }
|
||||
|
||||
|
||||
package Net::DNS::RR::OPT::EXTENDED_ERROR; # RFC8914
|
||||
|
||||
my @field15 = qw(INFO-CODE EXTRA-TEXT);
|
||||
|
||||
sub _compose {
|
||||
my ( $class, %argument ) = ( 'INFO-CODE' => 0, 'EXTRA-TEXT' => '', @_ );
|
||||
my ( $code, $text ) = @argument{@field15};
|
||||
pack 'na*', $code, Net::DNS::Text->new($text)->raw;
|
||||
}
|
||||
|
||||
sub _decompose {
|
||||
my ( $code, $text ) = unpack 'na*', $_[1];
|
||||
my @payload = (
|
||||
'INFO-CODE' => $code,
|
||||
'EXTRA-TEXT' => Net::DNS::Text->decode( \$text, 0, length $text )->value
|
||||
);
|
||||
}
|
||||
|
||||
sub _image {
|
||||
my %hash = &_decompose;
|
||||
my @image = map join( ' => ', $_, $hash{$_} ), @field15;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Net::DNS;
|
||||
$packet = Net::DNS::Packet->new( ... );
|
||||
|
||||
$packet->header->do(1); # extended flag
|
||||
|
||||
$packet->edns->size(1280); # UDP payload size
|
||||
|
||||
$packet->edns->option( COOKIE => 'rawbytes' );
|
||||
|
||||
$packet->edns->print;
|
||||
|
||||
;; EDNS version 0
|
||||
;; flags: 8000
|
||||
;; rcode: NOERROR
|
||||
;; size: 1280
|
||||
;; option: COOKIE => ( 7261776279746573 )
|
||||
;; DAU => ( 8, 10, 13, 14, 15, 16 )
|
||||
;; DHU => ( 1, 2, 4 )
|
||||
;; EXTENDED-ERROR => ( INFO-CODE => 123, EXTRA-TEXT => )
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
EDNS OPT pseudo resource record.
|
||||
|
||||
The OPT record supports EDNS protocol extensions and is not intended to be
|
||||
created, accessed or modified directly by user applications.
|
||||
|
||||
All EDNS features are performed indirectly by operations on the objects
|
||||
returned by the $packet->header and $packet->edns creator methods.
|
||||
The underlying mechanisms are entirely hidden from the user.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
The available methods are those inherited from the base class augmented
|
||||
by the type-specific methods defined in this package.
|
||||
|
||||
Use of undocumented package features or direct access to internal data
|
||||
structures is discouraged and could result in program termination or
|
||||
other unpredictable behaviour.
|
||||
|
||||
|
||||
=head2 version
|
||||
|
||||
$version = $rr->version;
|
||||
$rr->version( $version );
|
||||
|
||||
The version of EDNS supported by this OPT record.
|
||||
|
||||
=head2 size
|
||||
|
||||
$size = $packet->edns->size;
|
||||
$more = $packet->edns->size(1280);
|
||||
|
||||
size() advertises the maximum size (octets) of UDP packet that can be
|
||||
reassembled in the network stack of the originating host.
|
||||
|
||||
=head2 rcode
|
||||
|
||||
$extended_rcode = $packet->header->rcode;
|
||||
$incomplete_rcode = $packet->edns->rcode;
|
||||
|
||||
The 12 bit extended RCODE. The most significant 8 bits reside in the OPT
|
||||
record. The least significant 4 bits can only be obtained from the packet
|
||||
header.
|
||||
|
||||
=head2 flags
|
||||
|
||||
$edns_flags = $packet->edns->flags;
|
||||
|
||||
$do = $packet->header->do;
|
||||
$packet->header->do(1);
|
||||
|
||||
16 bit field containing EDNS extended header flags.
|
||||
|
||||
=head2 options, option
|
||||
|
||||
@option = $packet->edns->options;
|
||||
|
||||
$octets = $packet->edns->option($option_code);
|
||||
|
||||
$packet->edns->option( COOKIE => $octets );
|
||||
$packet->edns->option( 10 => $octets );
|
||||
|
||||
When called in a list context, options() returns a list of option codes
|
||||
found in the OPT record.
|
||||
|
||||
When called in a scalar context with a single argument,
|
||||
option() returns the uninterpreted octet string
|
||||
corresponding to the specified option.
|
||||
The method returns undef if the specified option is absent.
|
||||
|
||||
Options can be added or replaced by providing the (name => value) pair.
|
||||
The option is deleted if the value is undefined.
|
||||
|
||||
|
||||
When option() is called in a list context with a single argument,
|
||||
the returned values provide a structured interpretation
|
||||
appropriate to the specified option.
|
||||
|
||||
For example:
|
||||
|
||||
@algorithms = $packet->edns->option('DAU');
|
||||
|
||||
|
||||
For some options, a hash table is more convenient:
|
||||
|
||||
%hash_table = $packet->edns->option(15);
|
||||
$info_code = $hash_table{'INFO-CODE'};
|
||||
$extra_text = $hash_table{'EXTRA-TEXT'};
|
||||
|
||||
|
||||
Similar forms of array or hash syntax may be used to construct the
|
||||
option value:
|
||||
|
||||
$packet->edns->option( DHU => [1, 2, 4] );
|
||||
|
||||
$packet->edns->option( EXPIRE => {'EXPIRE-TIMER' => 604800} );
|
||||
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c)2001,2002 RIPE NCC. Author Olaf M. Kolkman.
|
||||
|
||||
Portions Copyright (c)2012,2017-2020 Dick Franks.
|
||||
|
||||
All rights reserved.
|
||||
|
||||
Package template (c)2009,2012 O.M.Kolkman and R.W.Franks.
|
||||
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Permission to use, copy, modify, and distribute this software and its
|
||||
documentation for any purpose and without fee is hereby granted, provided
|
||||
that the above copyright notice appear in all copies and that both that
|
||||
copyright notice and this permission notice appear in supporting
|
||||
documentation, and that the name of the author not be used in advertising
|
||||
or publicity pertaining to distribution of the software without specific
|
||||
prior written permission.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||||
THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||||
FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||||
DEALINGS IN THE SOFTWARE.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<perl>, L<Net::DNS>, L<Net::DNS::RR>, RFC6891, RFC3225
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user