package DDDSENUM;

# $Id: DDDSENUM.pm,v 1.11 2004/03/23 06:46:58 fujiwara Exp $

###########################################################################
#
# DDDSENUM - Perl ENUM resolver module
#            --- try to support non-terminal NAPTRs ---
#                (based on RFC3404 pseudo code)
#
# Copyright (c) 2004  Japan Registry Service Co., LTD.
# Copyright (c) 2004  Kazunori Fujiwara
# All Rights Reserved.
#
# Author: Kazunori Fujiwara <fujiwara@jprs.co.jp>
#
###########################################################################

use strict;
use vars qw($enumerror $ignore_order $rfc2916service);
use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION);

use Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(EnumQuery);
@EXPORT_OK = qw($enumerror);
$VERSION = 0.1;

$ignore_order = 0; # for DEBUG
$rfc2916service = 1; # RFC2916 service field compatible

use Net::DNS;

# &eval_regexp('!^+9433(.*)$!\1@dnslab.jp!', '+94330351');

use vars qw($eval_regexp_error);
sub eval_regexp($$) # ($regexp, $aus)
{
	my($reg,$aus) = @_;
	my(@value, $d, $pattern, $replace, $flag);

	$d = substr $reg, 0, 1;
	if (!defined($d) || $d =~ /[1-9i]/) {
		$eval_regexp_error = "bad delim-char:[$d]";
		return undef;
	}
	if ($d ne '\\') {
		unless ($reg =~ m/^$d(([^$d]|\\$d)+)$d(([^$d]|\\$d)+)$d(i?)$/) {
			$eval_regexp_error = "bad subst-expr:[$reg]";
			return undef;
		}
		$pattern = $1;
		$pattern =~ s/\\$d/$d/g;
		$replace = $3;
		$replace =~ s/\\$d/$d/g;
		$flag = $5; # ignore
	} else {
		unless ($reg =~ m/^\\(([^\\]|\\\\)+)\\(([^\\]|\\[1-9\\])+)\\(i?)$/) {
			$eval_regexp_error = "bad subst-expr:[$reg]";
			return undef;
		}
		$pattern = $1;
		$pattern =~ s/\\\\/\\/g;
		$replace = $3;
		$replace =~ s/\\\\/\\/g;
		$flag = $5; # ignore
	}

# check regular expression

# character '$' exist only last of $pattern.
# because ENUM AUS only contains digits and '+'.
	if ($pattern =~ /^\$[^\$]/) {
		$eval_regexp_error = "ere contains \$:[$pattern]";
		return undef;
	}
#
# Special case
#  ^+ must be ^\+
#
	$pattern =~ s/^\^\+/\^\\\+/;
	if ($aus =~ /$pattern/) {
		@value = $aus =~ //;
	} else {
		$eval_regexp_error = "aus doesnot match ere:aus=$aus ere=[$pattern]";
		return undef;
	}
	my $temp = '';
	while ($replace ne "") {
		last unless ($replace =~ m/^([^\\]*)\\([1-9])(.*)$/);
		if (1+$#value < $2) {
			$eval_regexp_error = "bad repl backref:\\$2";
			return undef;
		}
		$temp .= $1 . $value[$2-1];
		$replace = $3;
	}
	return $temp . $replace;
}


sub EnumQuery($$$%) #($aus, $enumdomain, $res, %enumservice)
{
	my ($aus, $enumdomain, $res, %enumservice) = @_;
	my ($key, $ok, $es, $es2, $query,$rr,$i,$j,$flag,$newkey,$order,$eval_es);
	my (@output) = (); 
	my $rewrite_flag;
	my $terminal;

#initialize for ENUM
	$eval_es = scalar(%enumservice);
	$ignore_order = 0;
	if (!($aus =~ /^\+(\d+)$/)) {
		$enumerror = "wrong aus";
		return ();
	}
	$key = join('.', reverse(split(//, $1))) . $enumdomain;
	$enumerror = "";

	if (!defined($res)) {
		$res = Net::DNS::Resolver->new();
	}
	if (!defined($key)) {
		$enumerror = "wrong AUS : $aus";
		return ();
	}

#initialize for DDDS loop

	my %key_list; # loop detection
	my ($curr_order, $max_order, $n_naptrs, $rewriteflag, $terminal);

	$key_list{$aus} = 1;

	do {
		$rewrite_flag = 0;
		$terminal = 0;
		if (defined($key_list{$key})) {
			$enumerror .= "DDDS loop detected:$key\n";
			return (); # detected DDDS loop;
		}
		$key_list{$key} = 1; # add key to list of "seens"
		$query = $res->query($key, "NAPTR");
			# get all NAPTR RRs for 'key'
		if (!$query) { 
			$enumerror = "NAPTR:query failed:".$key.":". $res->errorstring;
			return ();
		}
		my @records;
		# basic check
		foreach $rr ($query->answer) {
			next unless $rr->type eq "NAPTR";
			my %entry;
			$flag = $rr->flags;
			if ($flag eq "U" || $flag eq "u") {
				$entry{flags} = "u";
				if ($rr->regexp eq "") {
					next;
				}
			} elsif ($flag eq "") {
				$entry{flags} = "";
			} else {
				next;
			}
			$entry{order} = $rr->order;
			$entry{flags} = $rr->flags;
			$entry{preference} = $rr->preference;
			$entry{service} = $rr->service;
			$entry{regexp} = $rr->regexp;
			$entry{replacement} = $rr->replacement;
			push @records, \%entry;
		}
		@records = sort { my $tmp;
				($tmp = $a->{order} <=> $b->{order}) == 0 ?
				$a->{preference} <=> $b->{preference} : $tmp }
				@records;
		$n_naptrs = $#records + 1;
		$max_order = $records[$n_naptrs-1]->{order};
		INNER:for ($j = 0; $j < $n_naptrs && $records[$j]->{order} <= $max_order;
			$j++) {
			if ($records[$j]->{regexp} ne "") {
				next if ($records[$j]->{replacement} ne "");
				$newkey = &eval_regexp($records[$j]->{regexp}, $aus);
				if (!defined($newkey)) {
					$enumerror .= $records[$j]->{regexp} . ":" . $eval_regexp_error . "\n";
					next;
				}
			} else {
				$newkey = $records[$j]->{replacement};
			}
			# We did do a rewrite, shrink max_order to current value
			# so that delegation works properly
			# max_order = naptr[j].order;
			$max_order = $records[$j]->{order};

			# Will we know what to do with the protocol and services
			# specified in the NAPTR? If not, try next record.
			# if(!isKnownProto(naptr[j].services)) {
			#	continue;
			# }
			# if(!isKnownService(naptr[j].services)) {
			#	continue;
			# }
			$es = $records[$j]->{service};
			$es =~ y/A-Z/a-z/;
			next if (!($es =~ /^e2u\+(.+)$/));
			$es = $1;
			$es2 = '';
			foreach $i (split(/\+/, $es)) {
			    if ($eval_es == 0 || $enumservice{$i} != 0) {
					if ($records[$j]->{flags} eq "u") {
						my %entry;
						$entry{order} = $records[$j]->{order};
						$entry{pref} = $records[$j]->{preference};
						$entry{service} = $records[$j]->{service};
						$entry{servicefound} = $i;
						$entry{uri} = $newkey;
						push @output, \%entry;
						$rewriteflag = 1;
						$terminal = 1;
					} else {
						$rewriteflag = 1;
						$terminal = 0;
						$key = $newkey;
						last INNER;
					}
				}
			}
		}
		outerloop::;
	} while ($rewriteflag && !$terminal);
	return () if (!$rewriteflag);
	return sort { $a->{pref} <=> $b->{pref} } @output;
}

1;
__END__

=head1 NAME

DDDSENUM - Perl ENUM resolver with non-final NAPTR

=head1 DESCRIPTION

 DDDSENUM.pm is a ENUM resolver.
 It allows the programmer to perform ENUM DNS queries and DDDS evaluation.
 It resolve ENUM with assigned enumservices and returns URIs.
 It support non-final NAPTRs as described in RFC3404 appendix A.


 See RFC 3401,3402,3403,3404 and rfc2916bis.

=head1 SYMPOSIS

 use DDDSENUM.pm;
 use Net::DNS;

 @ret = &EnumQuery($aus, $enumdomain, $resolver, %enumservice);

 $AUS		ENUM Application Unique String    '+81352972571'
 $enumdomain	ENUM domainname 'e164.arpa' 'e164.jp'
 $resolver	Net::DNS::Resolver->new($nameserver) or undef
 %enumservice	ENUM services	$enumservice{'sip'}=1; or undef
				enumservice must be written in small case.
				non zero required

=head1 RETURN VALUES

  The ENUM_Query() function returns array of structure of query data.
  otherwise the value () is retuened and the global variable $ENUM::enumerror
  is set to indicate the error.

	ret[]->{order}           is order value
	ret[]->{pref}            is preference value
	ret[]->{service}         is service field
	ret[]->{servicefound}    is matched servicename.
	ret[]->{uri}             is URI

=head1 EXAMPLES

 The following examples show how to use the "ENUM" modules.

 Lookup number '+81301234567''s ENUM entry.
 enumservice is 'sip' and 'email:mailto'.
 ENUM domain is '.e164.arpa'
 use default resolver.

	use ENUM;

	my %enumservice = ( 'sip' => 1, 'email:mailto' => 1 );
	my @u = &EnumQuery('+81301234567', '.e164.arpa', undef, %enumservice);
	if (scalar(@u) == 0) {
		print "error: ", $ENUM::enumerror, "\n";
	} else {
		foreach my $r (@u) {
			print "uri is ", $r->{uri}, "\n";
		}
	}

 Lookup number '+81301234567''s ENUM entry. 
 enumservice is 'h323' and 'web:http'.
 ENUM domain is '.e164.jp'
 use another resolver (hostname is my.resolver).

	use ENUM;
	use Net::DNS;

	my %enumservice = ( 'h323' => 1, 'web:http' => 1 );
	my $res = Net::DNS::Resolver->new('my.resolver');
	my @u = &EnumQuery('+81301234567', '.e164.jp', $res, %enumservice);
	foreach my $r (@u) {
		print "uri is ", $r->{uri}, "\n";
	}

=head1 BUGS

 this DDDS evaluation code based on RFC3404 Appendix A. Pseudo code.
 - follow only single non-terminal NAPTR per single DNS query.
 incompatible with DDDS and rfc2916bis
 - this library accepts multiple enumservices.
 - this library may return multiple candidates.
 this function interface will be changed soon.

=head1 COPYRIGHT

 Copyright (c) 2004  Japan Registry Service, Co., LTD.
 Copyright (c) 2004  Kazunori Fujiwara
 All Rights Reserved

 Author: Kazunori Fujiwara <fujiwara@jprs.co.jp>

=cut