File Coverage

blib/lib/Net/DNS/Extlang.pm

Criterion	Covered	Total	%
statement	228	229	99.5
branch	117	134	87.3
condition	23	35	65.7
subroutine	23	24	95.8
pod	9	9	100.0
total	400	431	92.8

package Net::DNS::Extlang;

our $VERSION = '0.2';

=head1 NAME

Net::DNS::Extlang - DNS extension language


=head1 SYNOPSIS

    use Net::DNS::Extlang;

    $extobj = new Net::DNS::Extlang(
	domain   => 'arpa',
	file     => '/etc/dnsext.txt',
	lang     => 'en',
	resolver => $resobj
    )


=head1 DESCRIPTION

The Net::DNS::Extlang module reads and stores RR descriptions from files
or the DNS.  If file is provided, it reads descriptions from that file,
otherwise it looks in .rrname. and .rrtype.
for descriptions in the desired language.

Provide a resolver if you want other than the default resolver settings.

=cut


use strict;
use warnings;
use integer;
use Carp;


=head1 METHODS

=head2 new

    $extobj = new Net::DNS::Extlang(
	domain   => 'arpa',
	file     => '/etc/dnsext.txt',
	lang     => 'en',
	resolver => new Net::DNS::Resolver()
    )

Create an object corresponding to a set of extension language entries
in a file or the DNS.  Provide either a file or a domain argument.
If you provide a domain, the lang and resolver are optional.

In addition to using its methods, Net::DNS::Extlang can be accessed
by Net::DNS to create rrtype packages automatically as required.

=cut

sub new {
	my $class = shift;

	my %args = (
		lang => 'en',	domain => 'services.net.',		# defaults
		@_
		);

	my $self = bless {
		domain	 => $args{domain},
		file	 => $args{file},
		lang	 => $args{lang},
		resolver => $args{resolver},
		rrnames	 => {},					# RRs by name
		rrnums	 => {},					# RRs by number
		}, $class;

	$self->_xlreadfile( $args{file} ) if $args{file};

	return $self;
}


=head2 domain, file, lang, resolver

Access method which returns extlang configuration attribute.

=cut

sub domain { shift->{domain} }
sub file { shift->{file} }
sub lang { shift->{lang} }
sub resolver { shift->{resolver} }


# read a file, set the text parts of $self->rrnames and $self->rrnums

sub _xlreadfile {
	my ($self, $file) = @_;

	open(my $rrfile, "<", $file) or croak "Extlang file '$file' $!";
	my @xllist = ();

	while(<$rrfile>) {
		chomp;
		next if m/^\s*($|#)/;	# comments or blank line
		if( m/^\s/ ) {
			push @xllist, join ' ', split;
			next;
		}
		# must be a new one, store current one
		$self->xlstorerecord(@xllist) if scalar @xllist;

		@xllist = ($_);
	}
	$self->xlstorerecord(@xllist) if scalar @xllist;

	close $rrfile;
}


=head2 xlstorerecord

    $rrr = $ext->xlstorerecord( $identifier, @field )

Store a record with rrname/number and list of fields.

=cut

# only do rudimentary syntax checking here

# match head record, $1 = name, $2 = number, $3 = description
# ignores I/A third subfield
my $headpattern = qr{^ ([A-Z][-A-Z0-9]*) : (\d+)\S* \s* (.*) $}ix;


# match a field, $1 = type, $2 = quals, $3 - name, $4 = comment
my $fieldpattern = qr{^(I[124]|AAAA|AA|B32|B64|T6|X[P68]|[ANRSTXZ])
	(?:\[( (?: [CALMX]|[-A-Z0-9]+=\d+\W*)+ )\])?
	:? ([a-z][-a-z0-9]*)? \s*(.*) $}ix;


sub xlstorerecord {
	my ($self, $rr, @fieldlist) = @_;

	croak "no rr record" if !$rr;

	my ($rrname, $rrnum, $rrcomment ) = $rr =~ m{$headpattern}o;
	croak "invalid rr record $rr" if !$rrname or !$rrnum;

	# parse each field descriptor into a hash via $fieldpattern
	my @fieldstructs;
	foreach (@fieldlist) {
		m{$fieldpattern}o || croak "invalid field in $rrname: $_";
		my $q = $2 || '';
		push @fieldstructs, {
			type	=> uc($1),
			quals	=> join(',', sort split /,/, uc $q),	# alphabetize quals
			name	=> $3,
			comment	=> $4
		};
	}

	# make up an rr thing
	my $rrr = {
		mnemon => $rrname,
		number => 0 + $rrnum,
		comment => $rrcomment,
		fields => [@fieldstructs]
	};

	# stash it by name and number
	$self->{rrnames}->{$rrname} = $rrr;
	$self->{rrnums}->{$rrnum} = $rrr;
}

sub _xlstorerecord { &xlstorerecord }	## now a public method (used in RRTYPEgen and Net::DNS)


=head2 getrr

    $rrinfo = $ext->getrr(nameornumber)

Retrieve the rr description by number (if the argument is all digits)
or name (otherwise.)  $rrinfo is a reference to a hash with entries for
mnemon, number, comment, and fields: the lines in the description
stanza.  Each field is a hash with entries type (field type),
quals (optional qualifiers), name (optional field name), and comment.

Descriptions from a file are all loaded by new(), from the DNS
are fetched as needed.
If there's no description for that name or number it returns undef.

=cut

sub getrr {
	my ($self, $rrn) = @_;
	my $name;

	croak("Need rrname or rrtype in getrr") unless $rrn;

	if($rrn =~ m{^\d+$}) {		# look up by number
		return $self->{rrnums}->{$rrn} if $self->{rrnums}->{$rrn};
		return undef if defined $self->{file};		# not in the file
		$name = "$rrn.rrtype.$self->{domain}";		# try DNS

	} else {			# look up by name
		$rrn = uc $rrn;		# RRTYPES are UPPER CASE
		return $self->{rrnames}->{$rrn} if $self->{rrnames}->{$rrn};
		return undef if defined $self->{file};		# not in the file
		$name = "$rrn.rrname.$self->{domain}";		# try DNS
	}

	# look it up
	my $res = $self->{resolver} ||= do {
		require Net::DNS::Resolver;
		new Net::DNS::Resolver();
	};

	my $response = $res->query($name, 'TXT') || return;	# undef if nothing there

	foreach my $rr ($response->answer) {
		next if $rr->type ne 'TXT';

		my @txt = $rr->txtdata;

		next unless $txt[0] eq "RRTYPE=1";

		my ($trname, $trno) = $txt[1] =~ m{$headpattern}o;
		croak "invalid description $txt[1]" if !$trname or !$trno;

		# make sure it's the right rr
		croak "wrong rrtype $rrn $txt[1]" unless $txt[1] =~ m/$rrn/;

		shift @txt;		# get rid of desc tag
		return $self->xlstorerecord(@txt);	# will croak if bad syntax
	}
}

=head2 compile / compilerr

    $code = $ext->compile(nameornumber)
    $code = $ext->compilerr($rrr)

Compile the rr description into Net::DNS::RR: and return
the perl code, suitable to pass to eval().
nameornumber is looked up, $rrr is an rr description such as getrr()
returns.

If there's no description it returns null.

Compiled methods include:

_decode_rdata, _encode_rdata, _format_rdata, _parse_rdata, _defaults

get/set for each field named to match the field, or fieldN if the field
has no name or a duplicate name.
If field names match built in names or perl keywords, the get/set
method name is prefixed with 'f'.

=cut


# $rrr is a rrinfo hash, %pats are patterns to select from based on the
# type and quals where it looks for type[quals], then type, then
# "default". When checking for quals they are alphabetized so a query
# for N[C,A] will match N[A,C]
#my $CDEBUG = 0;

sub _cchunk($@) {
	my ($rrr, %pats) = @_;
	my $type = $rrr->{type};
	my $qual = $rrr->{quals};

	if($qual) {
		my $k = $type . "[$qual]";
#		print "check $k\n" if $CDEBUG;
		return $pats{$k} if exists $pats{$k};
	}

#	print "check $type\n" if $CDEBUG;
	return exists($pats{$type}) ? $pats{$type} : $pats{"default"};
}


# substitite  #WORD# in the string with $p{WORD} in the list
# csub($string, 'FOO' => "foo", 'BAR' => "bahr", ... )
sub _csub($@) {
	my ($str, %subs) = @_;

	for ($str) {
		s/#([A-Z]+)#/$subs{$1}/eg;
		return $_;
	}
}


# names that conflict with RR methods
my %dirtywords = map { ($_, 1) } qw( new decode encode canonical print string plain token name owner next last
type class ttl dump rdatastr rdata rdstring rdlength destroy autoload );

sub compile {
	my ($self, $rrn) = @_;

	croak("Need rrname or rrtype in compile") unless $rrn;

	my $rrr = $self->getrr($rrn);
	$self->compilerr($rrr) if $rrr;
}

sub compilerr {
	my ($self, $rrr) = @_;

	my $rrname = uc $rrr->{mnemon};
	my $rrnum = $rrr->{number};
	my $rrcomment = $rrr->{comment} || '';
	my $rrfields = $rrr->{fields};

	my ($usedomainname,		# if there's an N field
	    $usetext,			# if there's an S field
	    $usemailbox,		# if theres an N[A] field
	    $usebase64,			# if there's a B32 or B64 field
	    $usetime,			# if there's a time field
	    $userrtype,			# if there's a rrtype field
	    $usensechelp,		# if there's a rrtype list field or nsec3 base32
	    %fields,			# field names in use
	    $fieldno,			# to generate fieldN names
	    $decode,			# contents of decode routine
	    $encode,			# contents of encode routine
	    $format,			# contents of format routine
	    $parse,			# contents of parse routine
	    $defaults,			# contents of defaults routine
	    $fieldfns			# functions get/set fields
	   );

	foreach my $f (@$rrfields) {
		$fieldno++;
		my ($type, $quals, $name) = ($f->{type}, $f->{quals}, lc $f->{name});

		carp("Unimplemented field type Z[$quals] in $rrname") && return if $type eq "Z";

		# censor dirty words
		$name = $f->{name} = "f$name" if $dirtywords{$name};

		# make a name if there isn't one yet
		$f->{name} = $name = "field$fieldno" if !$name or exists $fields{$name};

		$fields{$name} = $fieldno;

		if($type eq 'N') {
			$usedomainname = 1;
			$usemailbox = 1 if $quals =~ m{A};
		} elsif($type eq 'S') {
			$usetext = 1;
		} elsif($type eq "B64") {
			$usebase64 = 1;
		} elsif($type eq "B32") {
			$usensechelp = 1;
		} elsif($type eq "T" or $type eq "T6") {
			$usetime = 1;
		} elsif($type eq "R" ) {
			if( $quals eq "L" ) {
				$usensechelp = 1;
			} else {
				$userrtype = 1;
			}
		}
	}
	# now get them in order, in a perhaps overcomplex way
	my @fields = map { $_->{name} } @$rrfields;

	#print "fields are ",join(",", @fields), "\n";

	# generate per-field functions
	$fieldfns = _perfield($rrfields);

	# default function
	$defaults = _fielddefault($rrfields);
	$decode = _fielddecode($rrfields);
	$encode = _fieldencode($rrfields);
	$parse = _fieldparse($rrfields);
	$format = _fieldformat($rrfields);

	# other modules to include, depending on the type
	my $uses = "";
	$uses = "use Net::DNS::DomainName;\n" if $usedomainname;
	$uses .= "use Net::DNS::Mailbox;\n" if $usemailbox;
	$uses .= "use Net::DNS::Text;\n" if $usetext;
	$uses .= "use MIME::Base64;\n" if $usebase64;
	$uses .= "use Net::DNS::Extlang::Time qw(_encodetime _string2time);\n" if $usetime;
	$uses .= "use Net::DNS::Parameters qw(typebyname typebyval);\n" if $userrtype;
	$uses .= "use Net::DNS::Extlang::Nsechelp;\n" if $usensechelp;


	# glom it all together and return string
my $identifier = $rrname;
$identifier =~ s/\W/_/g;

	return <<"CODE";
# generated package $rrname;	$rrcomment
package Net::DNS::RR::TYPE$rrnum;
use strict;
use base qw(Net::DNS::RR);
use integer;
use Carp;
$uses

$decode

$encode

$format

$parse

$defaults

$fieldfns


{
	# also make accessible by symbolic name
	package Net::DNS::RR::$identifier;
	our \@ISA = qw(Net::DNS::RR::TYPE$rrnum);	# Avoid "use base ...;" (RT#123702)
}


1;

__END__