local-lib5/lib/perl5/URI/_idna.pm

   1 package URI::_idna;
   2
   3 # This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep)
   4 # based on Python-2.6.4/Lib/encodings/idna.py
   5
   6 use strict;
   7 use URI::_punycode qw(encode_punycode decode_punycode);
   8 use Carp qw(croak);
   9
  10 my $ASCII = qr/^[\x00-\x7F]*\z/;
  11
  12 sub encode {
  13     my $idomain = shift;
  14     my @labels = split(/\./, $idomain, -1);
  15     my @last_empty;
  16     push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq "";
  17     for (@labels) {
  18         $_ = ToASCII($_);
  19     }
  20     return join(".", @labels, @last_empty);
  21 }
  22
  23 sub decode {
  24     my $domain = shift;
  25     return join(".", map ToUnicode($_), split(/\./, $domain, -1))
  26 }
  27
  28 sub nameprep { # XXX real implementation missing
  29     my $label = shift;
  30     $label = lc($label);
  31     return $label;
  32 }
  33
  34 sub check_size {
  35     my $label = shift;
  36     croak "Label empty" if $label eq "";
  37     croak "Label too long" if length($label) > 63;
  38     return $label;
  39 }
  40
  41 sub ToASCII {
  42     my $label = shift;
  43     return check_size($label) if $label =~ $ASCII;
  44
  45     # Step 2: nameprep
  46     $label = nameprep($label);
  47     # Step 3: UseSTD3ASCIIRules is false
  48     # Step 4: try ASCII again
  49     return check_size($label) if $label =~ $ASCII;
  50
  51     # Step 5: Check ACE prefix
  52     if ($label =~ /^xn--/) {
  53         croak "Label starts with ACE prefix";
  54     }
  55
  56     # Step 6: Encode with PUNYCODE
  57     $label = encode_punycode($label);
  58
  59     # Step 7: Prepend ACE prefix
  60     $label = "xn--$label";
  61
  62     # Step 8: Check size
  63     return check_size($label);
  64 }
  65
  66 sub ToUnicode {
  67     my $label = shift;
  68     $label = nameprep($label) unless $label =~ $ASCII;
  69     return $label unless $label =~ /^xn--/;
  70     my $label1 = decode_punycode(substr($label, 4));
  71     my $label2 = ToASCII($label);
  72     if (lc($label) ne $label2) {
  73         croak "IDNA does not round-trip: '$label' vs '$label2'";
  74     }
  75     return $label1;
  76 }
  77
  78 1;