Net::DNS::Domain - Domain Name System domains

    Net::DNS::Domain - Domain Name System domains

    use Net::DNS::Domain

    $domain = new Net::DNS::Domain('example.com');

    $domain = decode Net::DNS::Domain( \$buffer, $offset, $hash );

    ( $domain, $next ) = decode Net::DNS::Domain( \$buffer, $offset, $hash );

    $data = $domain->encode( $offset, $hash );

    $name = $domain->name;

    $mail = $domain->mailbox;

    $fqdn = $domain->string;

package Net::DNS::Domain;

#
# $Id: Domain.pm 836 2009-12-30 09:41:53Z olaf $
#
use vars qw($VERSION);
$VERSION = (qw$LastChangedRevision 700$)[1];

use strict;
use integer;
use Carp;

use constant ASCII => eval { chr(91) eq '['; };

require Encode unless ASCII;

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;
}

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';
}

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);
	}
}

sub name {
	_strip( shift->string );
}

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 ) || () );
}

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__


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