File: //usr/local/lib64/perl5/Net/DNS/Domain.pm
package Net::DNS::Domain;
#
# $Id: Domain.pm 836 2009-12-30 09:41:53Z olaf $
#
use vars qw($VERSION);
$VERSION = (qw$LastChangedRevision 700$)[1];
=head1 NAME
Net::DNS::Domain - Domain Name System domains
=head1 SYNOPSIS
use Net::DNS::Domain
=head1 DESCRIPTION
The C<Net::DNS::Domain> module implements a class of abstract
DNS domain objects with associated class and instance methods.
Each domain object instance represents a single DNS domain which
has a fixed identity throughout its lifetime.
Internally, the primary representation is a (possibly empty) list
of ASCII domain labels, and optional link to an ancestor domain
object topologically closer to the root of the DNS namespace.
The presentation form of the domain name is generated on demand
and the result cached within the object.
=cut
use strict;
use integer;
use Carp;
use constant ASCII => eval { chr(91) eq '['; };
require Encode unless ASCII;
=head1 METHODS
=head2 new
$domain = new Net::DNS::Domain('example.com');
Creates a domain object which represents the DNS domain
identified by the character string argument. The identifier
consists of a sequence of labels delimited by dots.
The argument string consists of printable characters from the
7-bit ASCII repertoire.
A character preceded by \ represents itself, without any special
interpretation.
Any 8-bit code point can be represented by \ followed by exactly
three decimal digits.
Character code points are ASCII, irrespective of the encoding
employed by the underlying platform.
No characters are associated with code points beyond 127.
Argument strings should be delimited by single quotes to avoid
escape sequences being misinterpreted by the compiler.
The character string presentation format follows the conventions
for zone files described in RFC1035.
=cut
sub new {
my $self = bless {}, shift;
my $identifier = shift;
confess 'domain identifier undefined' unless defined $identifier;
if ( $identifier =~ /\\/o ) {
$identifier =~ s/\\\\/\\092/go; # disguise escaped escape
$identifier =~ s/\\\./\\046/go; # disguise escaped dot
@{$self->{raw}} = map { _unescape($_) } split /\.+/o, $identifier if ASCII;
@{$self->{raw}} = map { Encode::encode( 'iso-8859-1', _unescape($_) ) }
split /\.+/o, $identifier
unless ASCII;
} else {
@{$self->{raw}} = split /\.+/o, $identifier if ASCII;
@{$self->{raw}} = split /\056+/o, Encode::encode( 'iso-8859-1', $identifier ) unless ASCII;
}
foreach ( @{$self->{raw}} ) {
next if ( length $_ || croak 'unexpected null domain label' ) < 64;
my $length = length $_;
carp "$length octet domain label truncated";
substr( $_, 63 ) = '';
}
return $self;
}
=head2 decode
$domain = decode Net::DNS::Domain( \$buffer, $offset, $hash );
( $domain, $next ) = decode Net::DNS::Domain( \$buffer, $offset, $hash );
Creates a domain object which represents the DNS domain
identified by the compressed name at the indicated offset within
the data buffer.
The argument list consists of a reference to a scalar containing
the wire-format data, specified offset and reference to a hash
used to represent compressed names.
The returned offset value indicates the start of the next item
in the data buffer.
=cut
sub decode {
my $class = shift;
my $self = bless {}, $class;
my $buffer = shift; # reference to data buffer
my $offset = shift || 0; # offset within buffer
my $hash = shift || {}; # hashed domain by offset
my $buflen = length $$buffer;
my $index = $offset;
while ( $index < $buflen ) {
unless ( my $length = unpack( "\@$index C", $$buffer ) ) {
$hash->{$offset} = $self;
return wantarray ? ( $self, ++$index ) : $self;
} elsif ( $length < 64 ) {
push( @{$self->{raw}}, substr( $$buffer, ++$index, $length ) );
$index += $length;
} elsif ( $length < 0xc0 ) {
croak 'corrupt wire-format label';
} else {
my $link = 0x3fff & unpack( "\@$index n", $$buffer );
last unless $link < $offset;
my $tail = $hash->{$link} || decode( $class, $buffer, $link, $hash );
$self->{pointer} = $tail;
$hash->{$offset} = defined $self->{raw} ? $self : $tail;
return wantarray ? ( $self, $index + 2 ) : $self;
}
}
croak 'corrupt wire-format data';
}
=head2 encode
$data = $domain->encode( $offset, $hash );
Returns the wire-format representation of the domain object
suitable for inclusion in a DNS packet buffer.
The optional arguments are the offset within the packet data
where the domain name is to be stored and a reference to a
hash table used to index compressed names within the packet.
=cut
sub encode {
my $self = shift;
my $offset = shift; # offset in data buffer
if ( my $hash = shift ) { # hashed offset by name
my $data = ''; # compressed wire format
my @labels = $self->_wire;
while (@labels) {
my $name = join( '.', @labels );
return $data . pack( 'n', $hash->{$name} ) if defined $hash->{$name};
my $label = shift @labels;
my $length = length $label;
$data .= pack( 'C a*', $length, $label );
next unless $offset < 0xc000;
$hash->{$name} = 0xc000 | $offset;
$offset += 1 + $length;
}
$data .= chr(0);
} else {
my $data = ''; # DNSSEC canonical uncompressed
foreach ( $self->_wire ) {
$data .= pack( 'C a*', length $_, lc $_ );
}
$data .= chr(0);
}
}
=head2 name
$name = $domain->name;
Returns a character string corresponding to the "typical" form of
domain name to which section 11 of RFC2181 alludes.
The string consists of printable characters from the 7-bit ASCII
repertoire. Code points outside this set are represented by the
appropriate numerical escape sequence.
=cut
sub name {
_strip( shift->string );
}
=head2 mailbox
$mail = $domain->mailbox;
Returns a character string containing the mailbox interpretation
of the domain name as described in RFC1035 section 8.
=cut
sub mailbox {
my @mail = map { _escape($_) } shift->_wire if ASCII;
@mail = map { Encode::decode( 'ascii', _escape($_) ) } shift->_wire unless ASCII;
my $mbox = shift(@mail) || '<>';
$mbox =~ s/\\\./\./g; # unescape dot
_strip( join '@', $mbox, join( '.', @mail ) || () );
}
=head2 string
$fqdn = $domain->string;
Returns a character string containing the absolute name of the
domain as described in RFC1035 section 5.1.
The string consists of printable characters from the 7-bit ASCII
repertoire. Code points outside this set are represented by the
appropriate numerical escape sequence.
Characters which have special meaning in a zone file, dots which
are part of a domain label, and the escape character itself are
represented by escape sequences which remove any such meaning.
=cut
sub string {
my $self = shift;
return $self->{string} if $self->{string};
my @label = map { _escape($_) } @{$self->{raw} || []} if ASCII;
@label = map { Encode::decode( 'ascii', _escape($_) ) } @{$self->{raw} || []} unless ASCII;
return $self->{string} = join( '.', @label ) . '.' unless $self->{pointer};
return $self->{string} = join( '.', @label, $self->{pointer}->string );
}
########################################
my %escape = eval { ## precalculated ASCII escape table
my %table;
foreach ( 34, 36, 40, 41, 46, 59, 64, 92 ) { # \x " $ ( ) . ; @ \
$table{chr($_)} = pack 'C*', 92, $_;
}
foreach ( 0 .. 32, 127 .. 255 ) { # \ddd
my $seq = sprintf( '\\%03u', $_ );
$seq = Encode::encode( 'ascii', $seq ) unless ASCII;
$table{chr($_)} = $seq;
}
return %table;
};
sub _escape { ## Escape non-printable characters in ASCII string
join( '', map { $escape{$_} || $_ } split( //, shift ) );
}
sub _unescape { ## Interpret escape sequences in character string
my $label = shift;
while ( $label =~ /\\(\d\d\d)/o ) {
my $x = chr($1);
$x .= $x if $1 eq '092';
$x = Encode::decode( 'iso-8859-1', $x ) unless ASCII;
$label =~ s/\\$1/$x/g;
}
$label =~ s/\\(.)/$1/g;
return $label;
}
sub _strip { ## Post-process domain name
my $name = shift || return '.';
$name =~ s/(\\\.)/\\$1/g; # disguise escaped dot
$name =~ s/(\\\d)/\\$1/g; # disguise numeric escape
$name =~ s/\\(.)/$1/g; # strip character escapes
chop $name if $name =~ /.+\.$/; # strip final dot
return $name;
}
sub _wire { ## Generate list of wire-format labels
my $self = shift;
return @{$self->{raw} || []} unless $self->{pointer};
return ( @{$self->{raw} || []}, $self->{pointer}->_wire );
}
use vars qw($AUTOLOAD);
sub AUTOLOAD { ## Default method
no strict;
@_ = ("method $AUTOLOAD undefined");
goto &{'Carp::confess'};
}
sub DESTROY { } ## Avoid tickling AUTOLOAD (in cleanup)
1;
__END__
########################################
=head1 BUGS
Platform-specific parts of the code are designed to be optimised
away by the compiler for reasons of efficiency. This is achieved
at considerable expense in terms of readability.
=head1 COPYRIGHT
Copyright (c)2009 Dick Franks.
All rights reserved.
This program is free software; you may redistribute it and/or
modify it under the same terms as Perl itself.
=head1 SEE ALSO
L<perl(1)>, L<Net::DNS>, RFC1035, RFC2181.
=cut