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