1package Net::IDN::Punycode::PP; 2 3use 5.008; 4 5use strict; 6use utf8; 7use warnings; 8 9use Carp; 10use Exporter; 11 12our $VERSION = "2.500"; 13 14our @ISA = qw(Exporter); 15our @EXPORT = (); 16our @EXPORT_OK = qw(encode_punycode decode_punycode); 17our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK ); 18 19use integer; 20 21use constant BASE => 36; 22use constant TMIN => 1; 23use constant TMAX => 26; 24use constant SKEW => 38; 25use constant DAMP => 700; 26use constant INITIAL_BIAS => 72; 27use constant INITIAL_N => 128; 28 29use constant UNICODE_MIN => 0; 30use constant UNICODE_MAX => 0x10FFFF; 31 32my $Delimiter = chr 0x2D; 33my $BasicRE = "\x00-\x7f"; 34my $PunyRE = "A-Za-z0-9"; 35 36sub _adapt { 37 my($delta, $numpoints, $firsttime) = @_; 38 $delta = int($firsttime ? $delta / DAMP : $delta / 2); 39 $delta += int($delta / $numpoints); 40 my $k = 0; 41 while ($delta > int(((BASE - TMIN) * TMAX) / 2)) { 42 $delta /= BASE - TMIN; 43 $k += BASE; 44 } 45 return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW)); 46} 47 48sub decode_punycode { 49 die("Usage: Net::IDN::Punycode::decode_punycode(input)") unless @_; 50 no warnings 'utf8'; 51 52 my $input = shift; 53 54 my $n = INITIAL_N; 55 my $i = 0; 56 my $bias = INITIAL_BIAS; 57 my @output; 58 59 return undef unless defined $input; 60 return '' unless length $input; 61 62 if($input =~ s/(.*)$Delimiter//os) { 63 my $base_chars = $1; 64 croak("non-base character in input for decode_punycode") 65 if $base_chars =~ m/[^$BasicRE]/os; 66 push @output, split //, $base_chars; 67 } 68 my $code = $input; 69 70 croak('invalid digit in input for decode_punycode') if $code =~ m/[^$PunyRE]/os; 71 72 utf8::downgrade($input); ## handling failure of downgrade is more expensive than 73 ## doing the above regexp w/ utf8 semantics 74 75 while(length $code) 76 { 77 my $oldi = $i; 78 my $w = 1; 79 LOOP: 80 for (my $k = BASE; 1; $k += BASE) { 81 my $cp = substr($code, 0, 1, ''); 82 croak("incomplete encoded code point in decode_punycode") if !defined $cp; 83 my $digit = ord $cp; 84 85 ## NB: this depends on the PunyRE catching invalid digit characters 86 ## before they turn up here 87 ## 88 $digit = $digit < 0x40 ? $digit + (26-0x30) : ($digit & 0x1f) -1; 89 90 $i += $digit * $w; 91 my $t = $k - $bias; 92 $t = $t < TMIN ? TMIN : $t > TMAX ? TMAX : $t; 93 94 last LOOP if $digit < $t; 95 $w *= (BASE - $t); 96 } 97 $bias = _adapt($i - $oldi, @output + 1, $oldi == 0); 98 $n += $i / (@output + 1); 99 $i = $i % (@output + 1); 100 croak('invalid code point') if $n < UNICODE_MIN or $n > UNICODE_MAX; 101 splice(@output, $i, 0, chr($n)); 102 $i++; 103 } 104 return join '', @output; 105} 106 107sub encode_punycode { 108 die("Usage: Net::IDN::Punycode::encode_punycode(input)") unless @_; 109 no warnings 'utf8'; 110 111 my $input = shift; 112 my $input_length = length $input; 113 114 ## my $output = join '', $input =~ m/([$BasicRE]+)/og; ## slower 115 my $output = $input; $output =~ s/[^$BasicRE]+//ogs; 116 117 my $h = my $bb = length $output; 118 $output .= $Delimiter if $bb > 0; 119 utf8::downgrade($output); ## no unnecessary use of utf8 semantics 120 121 my @input = map ord, split //, $input; 122 my @chars = sort { $a<=> $b } grep { $_ >= INITIAL_N } @input; 123 124 my $n = INITIAL_N; 125 my $delta = 0; 126 my $bias = INITIAL_BIAS; 127 128 foreach my $m (@chars) { 129 next if $m < $n; 130 $delta += ($m - $n) * ($h + 1); 131 $n = $m; 132 for(my $i = 0; $i < $input_length; $i++) 133 { 134 my $c = $input[$i]; 135 $delta++ if $c < $n; 136 if ($c == $n) { 137 my $q = $delta; 138 LOOP: 139 for (my $k = BASE; 1; $k += BASE) { 140 my $t = $k - $bias; 141 $t = $t < TMIN ? TMIN : $t > TMAX ? TMAX : $t; 142 143 last LOOP if $q < $t; 144 145 my $o = $t + (($q - $t) % (BASE - $t)); 146 $output .= chr $o + ($o < 26 ? 0x61 : 0x30-26); 147 148 $q = int(($q - $t) / (BASE - $t)); 149 } 150 croak("input exceeds punycode limit") if $q > BASE; 151 $output .= chr $q + ($q < 26 ? 0x61 : 0x30-26); 152 153 $bias = _adapt($delta, $h + 1, $h == $bb); 154 $delta = 0; 155 $h++; 156 } 157 } 158 $delta++; 159 $n++; 160 } 161 return $output; 162} 163 1641; 165__END__ 166 167=head1 NAME 168 169Net::IDN::Punycode::PP - pure-perl implementation of Net::IDN::Punycode 170 171=head1 DESCRIPTION 172 173See L<Net::IDN::Punycode>. 174 175=head1 AUTHORS 176 177Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> (versions 0.01 to 0.02) 178 179Claus FE<auml>rber E<lt>CFAERBER@cpan.orgE<gt> (from version 1.00) 180 181=head1 LICENSE 182 183Copyright 2002-2004 Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> 184 185Copyright 2007-2018 Claus FE<auml>rber E<lt>CFAERBER@cpan.orgE<gt> 186 187This library is free software; you can redistribute it and/or modify 188it under the same terms as Perl itself. 189 190=head1 SEE ALSO 191 192S<RFC 3492> (L<http://www.ietf.org/rfc/rfc3492.txt>), 193L<IETF::ACE>, L<Convert::RACE> 194 195=cut 196