package Net::IDN::UTS46;

require 5.008_001;

use strict;
use utf8;
use warnings;

use Carp;

our $VERSION = "1.900_20111224";
$VERSION = eval $VERSION;

our $IDNA_prefix = 'xn--';

use Unicode::Normalize 1 ();
use Net::IDN::Punycode 1 ();
use Net::IDN::UTS46::Mapping 5.002 ('/^(Map|Is).*/');				# UTS #46 is only defined from Unicode 5.2.0

sub to_unicode {
  my ($label, %param) = @_;
  no warnings 'utf8';

  $param{'TransitionalProcessing'} = 0;
  $label = process($label, %param);
  return $label;
}

sub to_ascii {
  my ($label, %param) = @_;
  no warnings 'utf8';

  my $pass_through = $label !~ m/[^\p{ASCII}\x2E\x{FF0E}\x{3002}\x{FF61}]/;

# 1. Apply appropriate processing
# 2. Break the result into labels at U+002E full stop;
#
  my @ll = process($label, %param);

# 3. Convert each label with non-ASCII characters into Punycode [RFC3492].
#
  foreach(@ll) {
    if(m/\P{ASCII}/) {
      eval { $_ = $IDNA_prefix . Net::IDN::Punycode::encode_punycode($_) };
      die "$@ [A3]" if $@;
      $pass_through = 0;
    }
  }

# 4. Verify DNS length restrictions.
#
  $label = join '.', @ll unless $pass_through;

  croak "label too long: '$1' [A4]" if $label =~ m/([^\.]{64,})/;
  croak "label empty: '$label' [A4]" if $label =~ m/\.\./;
  croak "domain name too long: '$label' [A4]" if $label =~ m/.{253}[^\.]/;
  croak "domain name empty: '$label' [A4]" if $label !~ m/[^\.]/ && !$pass_through && !$param{'TransitionalProcessing'};

  return $label;
}

sub process {
  my ($label, %param) = @_;
  no warnings 'utf8';

  $param{'TransitionalProcessing'} = 0	unless exists $param{'TransitionalProcessing'};
  $param{'UseSTD3ASCIIRules'} = 0	unless exists $param{'UseSTD3ASCIIRules'};
  $param{'AllowUnassigned'} = 0		unless exists $param{'AllowUnassigned'};

# 1. Map
#   - disallowed
#
  if($param{'AllowUnassigned'}) {
    $label =~ m/^(\P{IsDisallowed}}|\P{Assigned})*$/ and croak sprintf('disallowed character U+%04X', ord($1));
  } else {
    $label =~ m/(\p{IsDisallowed})/ and croak sprintf('disallowed character U+%04X', ord($1));
    $label =~ m/(\P{Assigned})/ and croak sprintf('unassigned character U+%04X (in this version of perl)', ord($1));
  }

  if($param{'UseSTD3ASCIIRules'}) {
    $label =~ m/(\p{IsDisallowedSTD3Valid})/ and croak sprintf('disallowed_STD3_valid character U+%04X', ord($1));
    $label =~ m/(\p{IsDisallowedSTD3Mapped})/ and croak sprintf('disallowed_STD3_mapped character U+%04X', ord($1));
  };

#   - ignored
#
  $label = MapIgnored($label);
  ## $label = MapDisallowedSTD3Ignored($label)	if(!$param{'UseSTD3ASCIIRules'});

#   - mapped
#
  $label = MapMapped($label);
  $label = MapDisallowedSTD3Mapped($label) 	if(!$param{'UseSTD3ASCIIRules'});

#  - deviation
  $label = MapDeviation($label)			if($param{'TransitionalProcessing'});

# 2. Normalize
#
  $label = Unicode::Normalize::NFC($label);

# 3. Break
#
  my @ll = split /\./, $label, -1;

# 4. Convert/Validate
#
  my $bidi = 0;

  foreach (@ll) {
    if(m/^$IDNA_prefix(\p{ASCII}+)$/oi) {
      $_ = Net::IDN::Punycode::decode_punycode($1);
      _validate_label($_,%param, 'TransitionalProcessing' => 0);
    } else {
      _validate_label($_,%param,'_AssumeNFC' => 1);
    }
    $bidi++ if !$bidi && m/[\p{Bc:R}\p{Bc:AL}\p{Bc:AN}]/;
  }

  if($bidi) {
    foreach(@ll) {
      _validate_bidi($_,%param);
    }
  }

  foreach(@ll) {
    _validate_contextj($_,%param);
  }

# Done: Join and return
#
  return wantarray ? (@ll) : join('.', @ll);
}

sub _validate_label {
  my($l,%param) = @_;
  no warnings 'utf8';

  $l eq Unicode::Normalize::NFC($l)	or croak "not in Unicode Normalization Form NFC [V1]" unless $param{'_AssumeNFC'};

  $l =~ m/^..--/			and croak "contains U+002D HYPHEN-MINUS in both third and forth position [V2]";
  $l =~ m/^-/				and croak "begins with U+002D HYPHEN-MINUS [V3]";
  $l =~ m/-$/				and croak "ends with U+002D HYPHEN-MINUS [V3]";
  $l =~ m/\./				and croak "contains U+0023 FULL STOP [V4]";
  $l =~ m/^\p{IsMark}/			and croak "begins with General_Category=Mark [V5]";

  if($param{'AllowUnassigned'}) {
    if($param{'TransitionalProcessing'}) {
      $l =~ m/[^\p{IsValid}\P{Assigned}]/			and croak "contains character that is not valid [V6]";
    } else {
      $l =~ m/[^\p{IsValid}\p{IsDeviation}\P{Assigned}]/	and croak "contains charachter that is not either valid or deviation [V6]";
    }
  } else {
    if($param{'TransitionalProcessing'}) {
      $l =~ m/[^\p{IsValid}]/					and croak "contains character that is not valid [V6]";
    } else {
      $l =~ m/[^\p{IsValid}\p{IsDeviation}]/			and croak "contains charachter that is not either valid or deviation [V6]";
    }
  }

  return 1;
}

sub _validate_bidi {
  my($l,%param) = @_;
  no warnings 'utf8';
  return 1 unless length($l);

  $l =~ m/^(?:(\p{Bc:L})|\p{Bc:R}|\p{Bc:AL})/ or die 'starts with character of wrong bidi class [B1]';

  if(!defined $1) { # RTL
    $l =~ m/[^\p{Bc:R}\p{Bc:AL}\p{Bc:AN}\p{Bc:EN}\p{Bc:ES}\p{Bc:CS}\p{Bc:ET}\p{Bc:ON}\p{Bc:BN}\p{Bc:NSM}]/ and croak 'contains characters with wrong bidi class for RTL [B2]';
    $l =~ m/[\p{Bc:R}\p{Bc:AL}\p{Bc:EN}\p{Bc:AN}][\p{Bc:NSM}\P{Assigned}]*$/ or croak 'ends with character of wrong bidi class for RTL [B3]';
    $l =~ m/\p{Bc:EN}.*\p{Bc:AN}|\p{Bc:AN}.*\p{Bc:EN}/ and croak 'contains characters with both bidi class EN and AN [B4]';
  } else { # LTR
    $l =~ m/[^\p{Bc:L}\p{Bc:EN}\p{Bc:ES}\p{Bc:CS}\p{Bc:ET}\p{Bc:ON}\p{Bc:BN}\p{Bc:NSM}]/ and croak 'contains characters with wrong bidi class for LTR [B5]';
    $l =~ m/[\p{Bc:L}\p{Bc:EN}][\p{Bc:NSM}\P{Assigned}]*$/ or croak 'ends with character of wrong bidi class for LTR [B6]';
  }
  return 1;
}

# For perl versions < 5.11, we use a conrete list of characters; this is safe
# because the Unicode version supported by theses perl versions will not be
# updated. For newer perl versions, we use the Unicode property (which is
# supported from 5.11), so we will always be up-to-date with the Unicode
# version supported by our underlying perl.
#
my $_RE_Ccc_Virama	= $] >= 5.011 ? qr/\p{Ccc:Virama}/ : qr/[\x{094D}\x{09CD}\x{0A4D}\x{0ACD}\x{0B4D}\x{0BCD}\x{0C4D}\x{0CCD}\x{0D4D}\x{0DCA}\x{0E3A}\x{0F84}\x{1039}\x{103A}\x{1714}\x{1734}\x{17D2}\x{1A60}\x{1B44}\x{1BAA}\x{1BF2}\x{1BF3}\x{2D7F}\x{A806}\x{A8C4}\x{A953}\x{A9C0}\x{ABED}\x{00010A3F}\x{00011046}\x{000110B9}]/;
my $_RE_JoiningType_L	= $] >= 5.011 ? qr/\p{Joining_Type:L}/ : qr/(?!)/;
my $_RE_JoiningType_R	= $] >= 5.011 ? qr/\p{Joining_Type:R}/ : qr/[\x{0622}-\x{0625}\x{0627}\x{0629}\x{062F}-\x{0632}\x{0648}\x{0671}-\x{0673}\x{0675}-\x{0677}\x{0688}-\x{0699}\x{06C0}\x{06C3}-\x{06CB}\x{06CD}\x{06CF}\x{06D2}\x{06D3}\x{06D5}\x{06EE}\x{06EF}\x{0710}\x{0715}-\x{0719}\x{071E}\x{0728}\x{072A}\x{072C}\x{072F}\x{074D}\x{0759}-\x{075B}\x{076B}\x{076C}\x{0771}\x{0773}\x{0774}\x{0778}\x{0779}]/;
my $_RE_JoiningType_D	= $] >= 5.011 ? qr/\p{Joining_Type:D}/ : qr/[\x{0620}\x{0626}\x{0628}\x{062A}-\x{062E}\x{0633}-\x{063F}\x{0641}-\x{0647}\x{0649}\x{064A}\x{066E}\x{066F}\x{0678}-\x{0687}\x{069A}-\x{06BF}\x{06C1}\x{06C2}\x{06CC}\x{06CE}\x{06D0}\x{06D1}\x{06FA}-\x{06FC}\x{06FF}\x{0712}-\x{0714}\x{071A}-\x{071D}\x{071F}-\x{0727}\x{0729}\x{072B}\x{072D}\x{072E}\x{074E}-\x{0758}\x{075C}-\x{076A}\x{076D}-\x{0770}\x{0772}\x{0775}-\x{0777}\x{077A}-\x{077F}\x{07CA}-\x{07EA}]/;
my $_RE_JoiningType_T	= $] >= 5.011 ? qr/\p{Joining_Type:T}/ : qr/[\x{00AD}\x{0300}-\x{036F}\x{0483}-\x{0489}\x{0591}-\x{05BD}\x{05BF}\x{05C1}\x{05C2}\x{05C4}\x{05C5}\x{05C7}\x{0610}-\x{061A}\x{064B}-\x{065F}\x{0670}\x{06D6}-\x{06DC}\x{06DF}-\x{06E4}\x{06E7}\x{06E8}\x{06EA}-\x{06ED}\x{070F}\x{0711}\x{0730}-\x{074A}\x{07A6}-\x{07B0}\x{07EB}-\x{07F3}\x{0816}-\x{0819}\x{081B}-\x{0823}\x{0825}-\x{0827}\x{0829}-\x{082D}\x{0859}-\x{085B}\x{0900}-\x{0902}\x{093A}\x{093C}\x{0941}-\x{0948}\x{094D}\x{0951}-\x{0957}\x{0962}\x{0963}\x{0981}\x{09BC}\x{09C1}-\x{09C4}\x{09CD}\x{09E2}\x{09E3}\x{0A01}\x{0A02}\x{0A3C}\x{0A41}\x{0A42}\x{0A47}\x{0A48}\x{0A4B}-\x{0A4D}\x{0A51}\x{0A70}\x{0A71}\x{0A75}\x{0A81}\x{0A82}\x{0ABC}\x{0AC1}-\x{0AC5}\x{0AC7}\x{0AC8}\x{0ACD}\x{0AE2}\x{0AE3}\x{0B01}\x{0B3C}\x{0B3F}\x{0B41}-\x{0B44}\x{0B4D}\x{0B56}\x{0B62}\x{0B63}\x{0B82}\x{0BC0}\x{0BCD}\x{0C3E}-\x{0C40}\x{0C46}-\x{0C48}\x{0C4A}-\x{0C4D}\x{0C55}\x{0C56}\x{0C62}\x{0C63}\x{0CBC}\x{0CBF}\x{0CC6}\x{0CCC}\x{0CCD}\x{0CE2}\x{0CE3}\x{0D41}-\x{0D44}\x{0D4D}\x{0D62}\x{0D63}\x{0DCA}\x{0DD2}-\x{0DD4}\x{0DD6}\x{0E31}\x{0E34}-\x{0E3A}\x{0E47}-\x{0E4E}\x{0EB1}\x{0EB4}-\x{0EB9}\x{0EBB}\x{0EBC}\x{0EC8}-\x{0ECD}\x{0F18}\x{0F19}\x{0F35}\x{0F37}\x{0F39}\x{0F71}-\x{0F7E}\x{0F80}-\x{0F84}\x{0F86}\x{0F87}\x{0F8D}-\x{0F97}\x{0F99}-\x{0FBC}\x{0FC6}\x{102D}-\x{1030}\x{1032}-\x{1037}\x{1039}\x{103A}\x{103D}\x{103E}\x{1058}\x{1059}\x{105E}-\x{1060}\x{1071}-\x{1074}\x{1082}\x{1085}\x{1086}\x{108D}\x{109D}\x{135D}-\x{135F}\x{1712}-\x{1714}\x{1732}-\x{1734}\x{1752}\x{1753}\x{1772}\x{1773}\x{17B4}\x{17B5}\x{17B7}-\x{17BD}\x{17C6}\x{17C9}-\x{17D3}\x{17DD}\x{180B}-\x{180D}\x{18A9}\x{1920}-\x{1922}\x{1927}\x{1928}\x{1932}\x{1939}-\x{193B}\x{1A17}\x{1A18}\x{1A56}\x{1A58}-\x{1A5E}\x{1A60}\x{1A62}\x{1A65}-\x{1A6C}\x{1A73}-\x{1A7C}\x{1A7F}\x{1B00}-\x{1B03}\x{1B34}\x{1B36}-\x{1B3A}\x{1B3C}\x{1B42}\x{1B6B}-\x{1B73}\x{1B80}\x{1B81}\x{1BA2}-\x{1BA5}\x{1BA8}\x{1BA9}\x{1BE6}\x{1BE8}\x{1BE9}\x{1BED}\x{1BEF}-\x{1BF1}\x{1C2C}-\x{1C33}\x{1C36}\x{1C37}\x{1CD0}-\x{1CD2}\x{1CD4}-\x{1CE0}\x{1CE2}-\x{1CE8}\x{1CED}\x{1DC0}-\x{1DE6}\x{1DFC}-\x{1DFF}\x{200B}\x{200E}\x{200F}\x{202A}-\x{202E}\x{2060}-\x{2064}\x{206A}-\x{206F}\x{20D0}-\x{20F0}\x{2CEF}-\x{2CF1}\x{2D7F}\x{2DE0}-\x{2DFF}\x{302A}-\x{302F}\x{3099}\x{309A}\x{A66F}-\x{A672}\x{A67C}\x{A67D}\x{A6F0}\x{A6F1}\x{A802}\x{A806}\x{A80B}\x{A825}\x{A826}\x{A8C4}\x{A8E0}-\x{A8F1}\x{A926}-\x{A92D}\x{A947}-\x{A951}\x{A980}-\x{A982}\x{A9B3}\x{A9B6}-\x{A9B9}\x{A9BC}\x{AA29}-\x{AA2E}\x{AA31}\x{AA32}\x{AA35}\x{AA36}\x{AA43}\x{AA4C}\x{AAB0}\x{AAB2}-\x{AAB4}\x{AAB7}\x{AAB8}\x{AABE}\x{AABF}\x{AAC1}\x{ABE5}\x{ABE8}\x{ABED}\x{FB1E}\x{FE00}-\x{FE0F}\x{FE20}-\x{FE26}\x{FEFF}\x{FFF9}-\x{FFFB}\x{101FD}\x{10A01}-\x{10A03}\x{10A05}\x{10A06}\x{10A0C}-\x{10A0F}\x{10A38}-\x{10A3A}\x{10A3F}\x{11001}\x{11038}-\x{11046}\x{11080}\x{11081}\x{110B3}-\x{110B6}\x{110B9}\x{110BA}\x{110BD}\x{1D167}-\x{1D169}\x{1D173}-\x{1D182}\x{1D185}-\x{1D18B}\x{1D1AA}-\x{1D1AD}\x{1D242}-\x{1D244}\x{E0001}\x{E0020}-\x{E007F}\x{E0100}-\x{E01EF}]/;

sub _validate_contextj {
  my($l,%param) = @_;
  no warnings 'utf8';
  return 1 unless defined($l) && length($l);

# catch ContextJ characters without defined rule (as of Unicode 6.0.0, this cannot match)
#
  $l =~ m/([^\x{200C}\x{200D}\P{Join_Control}])/ and croak sprintf "contains CONTEXTJ character U+%04X without defined rule [C1]", ord($1);

# RFC 5892, Appendix A.1. ZERO WIDTH NON-JOINER
#    Code point:
#       U+200C
# 
#    Overview:
#       This may occur in a formally cursive script (such as Arabic) in a
#       context where it breaks a cursive connection as required for
#       orthographic rules, as in the Persian language, for example.  It
#       also may occur in Indic scripts in a consonant-conjunct context
#       (immediately following a virama), to control required display of
#       such conjuncts.
# 
# 
#    Lookup:
#       True
#
#    Rule Set:
#       False;
#       If Canonical_Combining_Class(Before(cp)) .eq.  Virama Then True;
#       If RegExpMatch((Joining_Type:{L,D})(Joining_Type:T)*\u200C
#          (Joining_Type:T)*(Joining_Type:{R,D})) Then True;

  $l =~ m/
	$_RE_Ccc_Virama
	\x{200C}
     |
	(?: $_RE_JoiningType_L | $_RE_JoiningType_D) $_RE_JoiningType_T*
	\x{200C}
	 $_RE_JoiningType_T*(?: $_RE_JoiningType_R | $_RE_JoiningType_D)
     |
	(\x{200C})
    /xo and defined($1) and croak sprintf "rule for CONTEXTJ character U+%04X not satisfied [C2]", ord($1);

# RFC 5892, Appendix A.2. ZERO WIDTH JOINER
#
#    Code point:
#       U+200D
# 
#    Overview:
#       This may occur in Indic scripts in a consonant-conjunct context
#       (immediately following a virama), to control required display of
#       such conjuncts.
# 
#    Lookup:
#       True

#    Rule Set:
#       False;
#       If Canonical_Combining_Class(Before(cp)) .eq.  Virama Then True;

  $l =~ m/
	$_RE_Ccc_Virama
	\x{200D}
     |
	(\x{200D})
    /xo and defined($1) and croak sprintf "rule for CONTEXTJ character U+%04X not satisfied [C2]", ord($1);
}
