line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# $Id: Bootstring.pm,v 1.9 2004/06/01 08:52:29 sauber Exp $ |
2
|
|
|
|
|
|
|
# Encode and decode utf8 into a set of basic code points |
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package Encode::Bootstring; |
5
|
|
|
|
|
|
|
|
6
|
2
|
|
|
2
|
|
57568
|
use strict; |
|
2
|
|
|
|
|
6
|
|
|
2
|
|
|
|
|
91
|
|
7
|
2
|
|
|
2
|
|
3014
|
use integer; |
|
2
|
|
|
|
|
25
|
|
|
2
|
|
|
|
|
15
|
|
8
|
2
|
|
|
2
|
|
2383
|
use utf8; |
|
2
|
|
|
|
|
29
|
|
|
2
|
|
|
|
|
12
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
=head1 NAME |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
Encode::Bootstring - Encode and decode utf8 into a set of basic code points |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
=head1 VERSION |
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
VERSION 0.03 |
17
|
|
|
|
|
|
|
|
18
|
|
|
|
|
|
|
=cut |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
our $VERSION = '0.03'; |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
=head1 SYNOPSIS |
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
$BS = new Encode::Bootstring( |
25
|
|
|
|
|
|
|
BASIC => ["a".."z", "A".."Z", "0".."9"], |
26
|
|
|
|
|
|
|
TMAX => 53, |
27
|
|
|
|
|
|
|
SKEW => 78, |
28
|
|
|
|
|
|
|
INITIAL_BIAS => 32, |
29
|
|
|
|
|
|
|
TMIN => 38, |
30
|
|
|
|
|
|
|
DAMP => 40, |
31
|
|
|
|
|
|
|
DELIMITER => '_', |
32
|
|
|
|
|
|
|
); |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
$bootstring = $BS->encode($utf8); |
35
|
|
|
|
|
|
|
$utf8 = $BS->encode($bootstring); |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
=head1 DESCRIPTION |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
Punycode is a specific use of bootstring encoding; it encodes the |
40
|
|
|
|
|
|
|
larger code set to preprogrammed code set suitable for DNS names, such |
41
|
|
|
|
|
|
|
as ASCII characters and numbers. It also ignores casing of letters. |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
Bootstring on the other hand is the generalised concept and allows any |
44
|
|
|
|
|
|
|
code set to be encoded as any other smaller code set. |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
=head1 INTERFACE |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
All parameters are optional. Refer to RFC3492 for details of each parameter. |
49
|
|
|
|
|
|
|
The above parameters are suitable for encoding a variety of alphabets |
50
|
|
|
|
|
|
|
to ascii letters and numbers. |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=cut |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
# Constructor |
55
|
|
|
|
|
|
|
# |
56
|
|
|
|
|
|
|
sub new { |
57
|
1
|
|
|
1
|
0
|
15
|
my $invocant = shift; |
58
|
1
|
|
33
|
|
|
9
|
my $class = ref($invocant) || $invocant; |
59
|
1
|
|
|
|
|
3
|
my $self = { @_ }; |
60
|
1
|
|
|
|
|
5
|
bless $self, $class; |
61
|
1
|
|
|
|
|
5
|
$self->_initialize(); |
62
|
1
|
|
|
|
|
10
|
return $self; |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
# Initializer |
66
|
|
|
|
|
|
|
# |
67
|
|
|
|
|
|
|
# This load the basic code points table and set constants for encoding |
68
|
|
|
|
|
|
|
# and decoding. |
69
|
|
|
|
|
|
|
# Note: Are these constants reasonable? |
70
|
|
|
|
|
|
|
# |
71
|
|
|
|
|
|
|
sub _initialize { |
72
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
# Read parameters from new(); |
75
|
1
|
|
|
|
|
3
|
%{$self} = ( %{$self}, @_ ); |
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
9
|
|
76
|
|
|
|
|
|
|
|
77
|
|
|
|
|
|
|
# BASE is number of basic code points |
78
|
1
|
|
50
|
|
|
28
|
$self->{BASIC} ||= ["a".."z", "A".."Z", "0".."9"]; |
79
|
1
|
|
|
|
|
3
|
$self->{BASE} = scalar @{$self->{BASIC}}; |
|
1
|
|
|
|
|
3
|
|
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# Defaults |
82
|
1
|
|
50
|
|
|
11
|
$self->{DELIMITER} ||= '-'; |
83
|
1
|
|
50
|
|
|
7
|
$self->{TMIN} ||= 1; |
84
|
1
|
|
33
|
|
|
8
|
$self->{TMAX} ||= $self->{BASE} - 1; |
85
|
1
|
|
|
|
|
3
|
$self->{INITIAL_N} = $self->{BASE} + 1; |
86
|
1
|
|
50
|
|
|
8
|
$self->{INITIAL_BIAS} ||= 72; |
87
|
1
|
|
50
|
|
|
7
|
$self->{SKEW} ||= 38; |
88
|
1
|
|
50
|
|
|
6
|
$self->{DAMP} ||= 700; |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# Render a modification of ascii table |
91
|
1
|
|
|
|
|
5
|
$self->newtable(); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
# Handle errors |
95
|
|
|
|
|
|
|
# |
96
|
0
|
|
|
0
|
|
0
|
sub _croak { require Carp; Carp::croak(@_); } |
|
0
|
|
|
|
|
0
|
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
# Create a variation of the ascii table (or part of it or beyond) |
99
|
|
|
|
|
|
|
# where all basic code points are first. |
100
|
|
|
|
|
|
|
# |
101
|
|
|
|
|
|
|
sub newtable { |
102
|
1
|
|
|
1
|
0
|
3
|
my $self = shift; |
103
|
|
|
|
|
|
|
|
104
|
1
|
|
|
|
|
2
|
my $n = 0; |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
# Put basic code points in beginning of table |
107
|
1
|
|
|
|
|
3
|
for ( @{$self->{BASIC}} ) { |
|
1
|
|
|
|
|
3
|
|
108
|
62
|
|
|
|
|
135
|
$self->{ord}{$_} = $n; |
109
|
62
|
|
|
|
|
76
|
$n++; |
110
|
62
|
100
|
100
|
|
|
299
|
$self->{maxord} = ord if not exists $self->{maxord} or $self->{maxord} < ord; |
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# Put skipped chars after basic code points |
114
|
1
|
|
|
|
|
5
|
for ( 0..$self->{maxord} ) { |
115
|
123
|
|
|
|
|
159
|
my $c = chr $_; |
116
|
123
|
100
|
|
|
|
794
|
unless ( exists $self->{ord}{$c} ) { |
117
|
61
|
|
|
|
|
127
|
$self->{ord}{$c} = $n; |
118
|
61
|
|
|
|
|
105
|
$n++; |
119
|
|
|
|
|
|
|
} else { |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
# Create a reverse map |
124
|
1
|
|
|
|
|
5
|
%{$self->{chr}} = reverse %{$self->{ord}}; |
|
1
|
|
|
|
|
76
|
|
|
1
|
|
|
|
|
25
|
|
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# Input int output char using modified table |
128
|
|
|
|
|
|
|
# |
129
|
|
|
|
|
|
|
sub nchr { |
130
|
14
|
|
|
14
|
0
|
17
|
my($self,$c) = @_; |
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
#return $_[0] > $self->{maxord} ? chr($_[0]) : $self->{chr}{$_[0]} ; |
133
|
14
|
100
|
|
|
|
234
|
return $c > $self->{maxord} ? chr($c) : $self->{chr}{$c} ; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Input char output char using modified table |
137
|
|
|
|
|
|
|
# |
138
|
|
|
|
|
|
|
sub nord { |
139
|
22
|
|
|
22
|
0
|
35
|
my($self,$c) = @_; |
140
|
|
|
|
|
|
|
|
141
|
22
|
100
|
|
|
|
91
|
return exists $self->{ord}{$c} ? $self->{ord}{$c} : ord($c) ; |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
# Hex code of ascii/utf8 char |
145
|
|
|
|
|
|
|
# |
146
|
|
|
|
|
|
|
sub hex4 { |
147
|
0
|
|
|
0
|
0
|
0
|
return sprintf('%04x', ord(shift)); |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
|
150
|
|
|
|
|
|
|
# Dump modified table, for testing |
151
|
|
|
|
|
|
|
# |
152
|
|
|
|
|
|
|
sub dumptable { |
153
|
0
|
|
|
0
|
0
|
0
|
my $self = shift; |
154
|
|
|
|
|
|
|
|
155
|
0
|
|
|
|
|
0
|
for (0..$self->{maxord}) { |
156
|
0
|
|
|
|
|
0
|
printf "%d = %s\n", $_, $self->nchr($_); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
# The bootstring adaption algorithm |
161
|
|
|
|
|
|
|
# |
162
|
|
|
|
|
|
|
sub adapt { |
163
|
4
|
|
|
4
|
0
|
8
|
my($self,$delta, $numpoints, $firsttime) = @_; |
164
|
|
|
|
|
|
|
|
165
|
4
|
100
|
|
|
|
9
|
$delta = $firsttime |
166
|
|
|
|
|
|
|
? $delta / $self->{DAMP} |
167
|
|
|
|
|
|
|
: $delta / 2; |
168
|
4
|
|
|
|
|
5
|
$delta += $delta / $numpoints; |
169
|
4
|
|
|
|
|
5
|
my $k = 0; |
170
|
4
|
|
|
|
|
14
|
while ( $delta > (($self->{BASE}-$self->{TMIN})*$self->{TMAX})/2 ) { |
171
|
0
|
|
|
|
|
0
|
$delta /= $self->{BASE} - $self->{TMIN}; |
172
|
0
|
|
|
|
|
0
|
$k += $self->{BASE}; |
173
|
|
|
|
|
|
|
} |
174
|
4
|
|
|
|
|
11
|
return $k + ( (($self->{BASE}-$self->{TMIN}+1) * $delta) |
175
|
|
|
|
|
|
|
/ ($delta+$self->{SKEW}) ); |
176
|
|
|
|
|
|
|
} |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
=head2 encode |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
$encoded = $BS->encode( $raw ); |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
Encodes raw data. |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
=cut |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
# Encoding routine |
187
|
|
|
|
|
|
|
# |
188
|
|
|
|
|
|
|
sub encode { |
189
|
1
|
|
|
1
|
1
|
8
|
my $self = shift; |
190
|
1
|
|
|
|
|
2
|
my $input = shift; |
191
|
|
|
|
|
|
|
|
192
|
1
|
50
|
|
|
|
4
|
if ( exists $self->{DEBUG} ) { |
193
|
0
|
|
|
|
|
0
|
$self->{trace} = "Encoding trace of $input:\n\n"; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
#my @input = split //, $input; # doesn't work in 5.6.x! |
197
|
1
|
|
|
|
|
13
|
my @input = map substr($input, $_, 1), 0..length($input)-1; |
198
|
|
|
|
|
|
|
|
199
|
1
|
|
|
|
|
3
|
my $n = $self->{INITIAL_N}; |
200
|
1
|
|
|
|
|
2
|
my $delta = 0; |
201
|
1
|
|
|
|
|
2
|
my $bias = $self->{INITIAL_BIAS}; |
202
|
1
|
50
|
|
|
|
5
|
unless ( exists $self->{BasicRE} ) { |
203
|
1
|
|
|
|
|
2
|
my $BasicRE = join'',@{$self->{BASIC}}; |
|
1
|
|
|
|
|
7
|
|
204
|
1
|
|
|
|
|
55
|
$self->{BasicRE} = qr/[$BasicRE]/; |
205
|
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
|
207
|
|
|
|
|
|
|
# Trace output |
208
|
1
|
50
|
|
|
|
16
|
if ( exists $self->{DEBUG} ) { |
209
|
0
|
|
|
|
|
0
|
$self->{trace} .= "bias is $bias\n" |
210
|
|
|
|
|
|
|
. "input is:\n" |
211
|
|
|
|
|
|
|
. join(' ', map hex4($_), @input) . "\n"; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
1
|
|
|
|
|
3
|
my @output; |
215
|
|
|
|
|
|
|
my @tmpout; |
216
|
|
|
|
|
|
|
#my @basic = grep /$BasicRE/, @input; |
217
|
1
|
|
|
|
|
31
|
my @basic = grep /$self->{BasicRE}/, @input; |
218
|
1
|
|
|
|
|
9
|
my $h = my $b = @basic; |
219
|
1
|
50
|
|
|
|
7
|
push @output, @basic, $self->{DELIMITER} if $b > 0; |
220
|
|
|
|
|
|
|
|
221
|
1
|
50
|
|
|
|
4
|
if ( exists $self->{DEBUG} ) { |
222
|
0
|
0
|
|
|
|
0
|
if ( @basic ) { |
223
|
0
|
|
|
|
|
0
|
$self->{trace} .= 'basic code points (' |
224
|
|
|
|
|
|
|
. join(', ', map hex4($_), @basic) |
225
|
|
|
|
|
|
|
. ') are copied to literal portion: "' |
226
|
|
|
|
|
|
|
. join('', @output) |
227
|
|
|
|
|
|
|
. '"' . "\n"; |
228
|
|
|
|
|
|
|
} else { |
229
|
0
|
|
|
|
|
0
|
$self->{trace} .= "there are no basic code points, so no literal portion\n"; |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
|
233
|
1
|
|
|
|
|
4
|
my @ninput = map $self->nord($_), @input; |
234
|
1
|
|
|
|
|
4
|
while ($h < @input) { |
235
|
2
|
|
|
|
|
4
|
my $m = min(grep { $_ >= $n } @ninput); |
|
20
|
|
|
|
|
33
|
|
236
|
2
|
50
|
|
|
|
6
|
if ( exists $self->{DEBUG} ) { |
237
|
0
|
|
|
|
|
0
|
$self->{trace} .= sprintf "next code point to insert is %04x\n", $m; |
238
|
|
|
|
|
|
|
} |
239
|
2
|
|
|
|
|
4
|
$delta += ($m - $n) * ($h + 1); |
240
|
2
|
|
|
|
|
2
|
$n = $m; |
241
|
2
|
|
|
|
|
3
|
for my $c (@ninput) { |
242
|
|
|
|
|
|
|
#my $c = $i; |
243
|
20
|
100
|
|
|
|
36
|
$delta++ if $c < $n; |
244
|
20
|
100
|
|
|
|
50
|
if ($c == $n) { |
245
|
2
|
|
|
|
|
3
|
my $q = $delta; |
246
|
|
|
|
|
|
|
LOOP: |
247
|
2
|
|
|
|
|
3
|
for (my $k = $self->{BASE}; 1; $k += $self->{BASE}) { |
248
|
4
|
100
|
|
|
|
14
|
my $t = ($k <= $bias) ? $self->{TMIN} : |
|
|
100
|
|
|
|
|
|
249
|
|
|
|
|
|
|
($k >= $bias + $self->{TMAX}) ? $self->{TMAX} : $k - $bias; |
250
|
4
|
100
|
|
|
|
11
|
last LOOP if $q < $t; |
251
|
2
|
|
|
|
|
17
|
my $cp = $self->nchr($t + (($q - $t) % ($self->{BASE} - $t))); |
252
|
2
|
|
|
|
|
5
|
push @tmpout, $cp; |
253
|
2
|
|
|
|
|
11
|
$q = ($q - $t) / ($self->{BASE} - $t); |
254
|
|
|
|
|
|
|
} |
255
|
2
|
|
|
|
|
5
|
push @tmpout, $self->nchr($q); |
256
|
2
|
|
|
|
|
7
|
$bias = $self->adapt($delta, $h + 1, $h == $b); |
257
|
2
|
|
|
|
|
2
|
$delta = 0; |
258
|
2
|
|
|
|
|
5
|
$h++; |
259
|
|
|
|
|
|
|
} |
260
|
|
|
|
|
|
|
} |
261
|
2
|
50
|
|
|
|
12
|
if ( exists $self->{DEBUG} ) { |
262
|
0
|
|
|
|
|
0
|
$self->{trace} .= "needed delta is $delta, encodes as " . '"' |
263
|
|
|
|
|
|
|
. join('',@tmpout) . '"' . "\n" |
264
|
|
|
|
|
|
|
. "bias becomes $bias\n"; |
265
|
|
|
|
|
|
|
} |
266
|
2
|
|
|
|
|
5
|
push @output, @tmpout; |
267
|
2
|
|
|
|
|
5
|
@tmpout = (); |
268
|
2
|
|
|
|
|
2
|
$delta++; |
269
|
2
|
|
|
|
|
7
|
$n++; |
270
|
|
|
|
|
|
|
} |
271
|
1
|
50
|
|
|
|
4
|
if ( exists $self->{DEBUG} ) { |
272
|
0
|
|
|
|
|
0
|
$self->{trace} .= 'output is "' . join('', @output) . '"' . "\n"; |
273
|
|
|
|
|
|
|
} |
274
|
1
|
|
|
|
|
8
|
return join '', @output; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
# Find minimum value in list |
278
|
|
|
|
|
|
|
# |
279
|
|
|
|
|
|
|
sub min { |
280
|
2
|
|
|
2
|
0
|
3
|
my $min = shift; |
281
|
2
|
50
|
|
|
|
5
|
for (@_) { $min = $_ if $_ <= $min } |
|
1
|
|
|
|
|
4
|
|
282
|
2
|
|
|
|
|
4
|
return $min; |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
|
|
|
|
|
|
=head2 decode |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
$original = $BS->decode( $encoded ); |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
Decode bootstring encoded data. |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
=cut |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
# Bootstring decoding routing |
294
|
|
|
|
|
|
|
# |
295
|
|
|
|
|
|
|
sub decode{ |
296
|
1
|
|
|
1
|
1
|
5
|
my $self = shift; |
297
|
1
|
|
|
|
|
2
|
my $code = shift; |
298
|
|
|
|
|
|
|
|
299
|
1
|
50
|
|
|
|
4
|
if ( exists $self->{DEBUG} ) { |
300
|
0
|
|
|
|
|
0
|
$self->{trace} = "Decoding trace of $code:\n\n"; |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
1
|
|
|
|
|
2
|
my $n = $self->{INITIAL_N}; |
304
|
1
|
|
|
|
|
1
|
my $i = 0; |
305
|
1
|
|
|
|
|
2
|
my $bias = $self->{INITIAL_BIAS}; |
306
|
|
|
|
|
|
|
#my $BasicRE = join'',@{$self->{BASIC}}; |
307
|
|
|
|
|
|
|
#$BasicRE = qr/[$BasicRE]/; |
308
|
|
|
|
|
|
|
#$BasicRE = qr/[join'',@{$self->{BASIC}}]/; |
309
|
|
|
|
|
|
|
|
310
|
1
|
|
|
|
|
2
|
my @output; |
311
|
|
|
|
|
|
|
|
312
|
1
|
50
|
|
|
|
3
|
if ( exists $self->{DEBUG} ) { |
313
|
0
|
|
|
|
|
0
|
$self->{trace} .= "n is $n, i is $i, bias = $bias\n" |
314
|
|
|
|
|
|
|
. 'input is "' . $code . '"' . "\n"; |
315
|
|
|
|
|
|
|
} |
316
|
|
|
|
|
|
|
|
317
|
1
|
50
|
|
|
|
30
|
if ($code =~ s/(.*)$self->{DELIMITER}//o) { |
318
|
1
|
|
|
|
|
10
|
push @output, map $self->nord($_), split //, $1; |
319
|
1
|
50
|
|
|
|
5
|
if ( exists $self->{DEBUG} ) { |
320
|
0
|
|
|
|
|
0
|
$self->{trace} .= 'literal portion is "' . $1 . $self->{DELIMITER} |
321
|
|
|
|
|
|
|
. '", so extended string starts as:' . "\n" |
322
|
|
|
|
|
|
|
. join(' ', map hex4($self->nchr($_)), @output) . "\n"; |
323
|
|
|
|
|
|
|
} |
324
|
1
|
|
|
|
|
2
|
my $bas = join('',@{$self->{BASIC}}); |
|
1
|
|
|
|
|
7
|
|
325
|
1
|
|
|
|
|
5
|
for ( split //, $1 ) { |
326
|
8
|
50
|
|
|
|
29
|
return _croak('non-basic code point' ) unless $bas =~ /$_/o; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} else { |
329
|
0
|
0
|
|
|
|
0
|
if ( exists $self->{DEBUG} ) { |
330
|
0
|
|
|
|
|
0
|
$self->{trace} .= |
331
|
|
|
|
|
|
|
"there is no delimiter, so extended string starts empty\n"; |
332
|
|
|
|
|
|
|
} |
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
|
335
|
1
|
|
|
|
|
4
|
while ($code) { |
336
|
2
|
|
|
|
|
3
|
my $oldi = $i; |
337
|
2
|
|
|
|
|
2
|
my $w = 1; |
338
|
2
|
50
|
|
|
|
6
|
if ( exists $self->{DEBUG} ) { |
339
|
0
|
|
|
|
|
0
|
$self->{trace} .= 'delta "'; |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
LOOP: |
342
|
2
|
|
|
|
|
5
|
for (my $k = $self->{BASE}; 1; $k += $self->{BASE}) { |
343
|
4
|
|
|
|
|
9
|
my $cp = substr($code, 0, 1, ''); |
344
|
4
|
|
|
|
|
7
|
my $digit = $self->nord($cp); |
345
|
4
|
50
|
|
|
|
13
|
if ( exists $self->{DEBUG} ) { |
346
|
0
|
|
|
|
|
0
|
$self->{trace} .= $cp; |
347
|
|
|
|
|
|
|
} |
348
|
4
|
50
|
|
|
|
14
|
defined $digit or return _croak("invalid punycode input"); |
349
|
4
|
|
|
|
|
12
|
$i += $digit * $w; |
350
|
4
|
100
|
|
|
|
13
|
my $t = ($k <= $bias) |
|
|
100
|
|
|
|
|
|
351
|
|
|
|
|
|
|
? $self->{TMIN} |
352
|
|
|
|
|
|
|
: ($k >= $bias + $self->{TMAX}) |
353
|
|
|
|
|
|
|
? $self->{TMAX} |
354
|
|
|
|
|
|
|
: $k - $bias; |
355
|
4
|
100
|
|
|
|
17
|
last LOOP if $digit < $t; |
356
|
2
|
|
|
|
|
5
|
$w *= ($self->{BASE} - $t); |
357
|
|
|
|
|
|
|
} |
358
|
2
|
50
|
|
|
|
6
|
if ( exists $self->{DEBUG} ) { |
359
|
0
|
|
|
|
|
0
|
$self->{trace} .= '" decodes to ' . "$i\n"; |
360
|
|
|
|
|
|
|
} |
361
|
2
|
|
|
|
|
5
|
$bias = $self->adapt($i - $oldi, @output + 1, $oldi == 0); |
362
|
2
|
50
|
|
|
|
6
|
if ( exists $self->{DEBUG} ) { |
363
|
0
|
|
|
|
|
0
|
$self->{trace} .= "bias becomes $bias\n"; |
364
|
|
|
|
|
|
|
} |
365
|
2
|
|
|
|
|
3
|
$n += $i / (@output + 1); |
366
|
2
|
|
|
|
|
4
|
$i = $i % (@output + 1); |
367
|
2
|
|
|
|
|
4
|
splice(@output, $i, 0, $n); |
368
|
2
|
50
|
|
|
|
5
|
if ( exists $self->{DEBUG} ) { |
369
|
0
|
|
|
|
|
0
|
$self->{trace} .= join(' ', map hex4($self->nchr($_)), @output) . "\n"; |
370
|
|
|
|
|
|
|
} |
371
|
2
|
|
|
|
|
6
|
$i++; |
372
|
|
|
|
|
|
|
} |
373
|
1
|
|
|
|
|
3
|
my $res = pack("C*", map ord $self->nchr($_), @output); |
374
|
1
|
|
|
|
|
5
|
return $res; |
375
|
|
|
|
|
|
|
} |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
=head1 AUTHOR |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
Soren Dossing, C<< >> |
380
|
|
|
|
|
|
|
|
381
|
|
|
|
|
|
|
=head1 BUGS |
382
|
|
|
|
|
|
|
|
383
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through |
384
|
|
|
|
|
|
|
the web interface at |
385
|
|
|
|
|
|
|
L. I will be notified, and then you'll |
386
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
=head1 SUPPORT |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
391
|
|
|
|
|
|
|
|
392
|
|
|
|
|
|
|
perldoc Encode::Bootstring |
393
|
|
|
|
|
|
|
|
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
You can also look for information at: |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
=over 4 |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker |
400
|
|
|
|
|
|
|
|
401
|
|
|
|
|
|
|
L |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
404
|
|
|
|
|
|
|
|
405
|
|
|
|
|
|
|
L |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
=item * CPAN Ratings |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
L |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
=item * Search CPAN |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
L |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
=back |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
Adam M. Costello for punycode reference implementation, and for advice and |
421
|
|
|
|
|
|
|
review of this more generic module. |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
=head1 COPYRIGHT & LICENSE |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
Copyright 2009 Soren Dossing. |
426
|
|
|
|
|
|
|
|
427
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
428
|
|
|
|
|
|
|
under the terms of either: the GNU General Public License as published |
429
|
|
|
|
|
|
|
by the Free Software Foundation; or the Artistic License. |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
See http://dev.perl.org/licenses/ for more information. |
432
|
|
|
|
|
|
|
|
433
|
|
|
|
|
|
|
|
434
|
|
|
|
|
|
|
=cut |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
1; # End of Encode::Bootstring |