File | /usr/local/lib/perl5/site_perl/5.10.1/URI/_punycode.pm |
Statements Executed | 35 |
Statement Execution Time | 918µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 13µs | 16µs | BEGIN@3 | URI::_punycode::
1 | 1 | 1 | 9µs | 13µs | BEGIN@10 | URI::_punycode::
1 | 1 | 1 | 9µs | 63µs | BEGIN@14 | URI::_punycode::
1 | 1 | 1 | 7µs | 36µs | BEGIN@16 | URI::_punycode::
1 | 1 | 1 | 6µs | 32µs | BEGIN@15 | URI::_punycode::
1 | 1 | 1 | 6µs | 29µs | BEGIN@17 | URI::_punycode::
1 | 1 | 1 | 6µs | 35µs | BEGIN@20 | URI::_punycode::
1 | 1 | 1 | 6µs | 29µs | BEGIN@18 | URI::_punycode::
1 | 1 | 2 | 6µs | 6µs | CORE:qr (opcode) | URI::_punycode::
1 | 1 | 1 | 6µs | 28µs | BEGIN@19 | URI::_punycode::
0 | 0 | 0 | 0s | 0s | _croak | URI::_punycode::
0 | 0 | 0 | 0s | 0s | adapt | URI::_punycode::
0 | 0 | 0 | 0s | 0s | code_point | URI::_punycode::
0 | 0 | 0 | 0s | 0s | decode_punycode | URI::_punycode::
0 | 0 | 0 | 0s | 0s | digit_value | URI::_punycode::
0 | 0 | 0 | 0s | 0s | encode_punycode | URI::_punycode::
0 | 0 | 0 | 0s | 0s | min | URI::_punycode::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package URI::_punycode; | ||||
2 | |||||
3 | 3 | 54µs | 2 | 19µs | # spent 16µs (13+3) within URI::_punycode::BEGIN@3 which was called
# once (13µs+3µs) by URI::_idna::BEGIN@7 at line 3 # spent 16µs making 1 call to URI::_punycode::BEGIN@3
# spent 3µs making 1 call to strict::import |
4 | 1 | 400ns | our $VERSION = 0.02; | ||
5 | |||||
6 | 1 | 900ns | require Exporter; | ||
7 | 1 | 8µs | our @ISA = qw(Exporter); | ||
8 | 1 | 600ns | our @EXPORT = qw(encode_punycode decode_punycode); | ||
9 | |||||
10 | 3 | 34µs | 2 | 16µs | # spent 13µs (9+4) within URI::_punycode::BEGIN@10 which was called
# once (9µs+4µs) by URI::_idna::BEGIN@7 at line 10 # spent 13µs making 1 call to URI::_punycode::BEGIN@10
# spent 4µs making 1 call to integer::import |
11 | |||||
12 | 1 | 100ns | our $DEBUG = 0; | ||
13 | |||||
14 | 3 | 28µs | 2 | 118µs | # spent 63µs (9+54) within URI::_punycode::BEGIN@14 which was called
# once (9µs+54µs) by URI::_idna::BEGIN@7 at line 14 # spent 63µs making 1 call to URI::_punycode::BEGIN@14
# spent 54µs making 1 call to constant::import |
15 | 3 | 24µs | 2 | 57µs | # spent 32µs (6+25) within URI::_punycode::BEGIN@15 which was called
# once (6µs+25µs) by URI::_idna::BEGIN@7 at line 15 # spent 32µs making 1 call to URI::_punycode::BEGIN@15
# spent 25µs making 1 call to constant::import |
16 | 3 | 21µs | 2 | 65µs | # spent 36µs (7+29) within URI::_punycode::BEGIN@16 which was called
# once (7µs+29µs) by URI::_idna::BEGIN@7 at line 16 # spent 36µs making 1 call to URI::_punycode::BEGIN@16
# spent 29µs making 1 call to constant::import |
17 | 3 | 21µs | 2 | 52µs | # spent 29µs (6+23) within URI::_punycode::BEGIN@17 which was called
# once (6µs+23µs) by URI::_idna::BEGIN@7 at line 17 # spent 29µs making 1 call to URI::_punycode::BEGIN@17
# spent 23µs making 1 call to constant::import |
18 | 3 | 21µs | 2 | 53µs | # spent 29µs (6+24) within URI::_punycode::BEGIN@18 which was called
# once (6µs+24µs) by URI::_idna::BEGIN@7 at line 18 # spent 29µs making 1 call to URI::_punycode::BEGIN@18
# spent 24µs making 1 call to constant::import |
19 | 3 | 21µs | 2 | 51µs | # spent 28µs (6+23) within URI::_punycode::BEGIN@19 which was called
# once (6µs+23µs) by URI::_idna::BEGIN@7 at line 19 # spent 28µs making 1 call to URI::_punycode::BEGIN@19
# spent 23µs making 1 call to constant::import |
20 | 3 | 661µs | 2 | 64µs | # spent 35µs (6+29) within URI::_punycode::BEGIN@20 which was called
# once (6µs+29µs) by URI::_idna::BEGIN@7 at line 20 # spent 35µs making 1 call to URI::_punycode::BEGIN@20
# spent 29µs making 1 call to constant::import |
21 | |||||
22 | 1 | 300ns | my $Delimiter = chr 0x2D; | ||
23 | 1 | 16µs | 1 | 6µs | my $BasicRE = qr/[\x00-\x7f]/; # spent 6µs making 1 call to URI::_punycode::CORE:qr |
24 | |||||
25 | sub _croak { require Carp; Carp::croak(@_); } | ||||
26 | |||||
27 | sub digit_value { | ||||
28 | my $code = shift; | ||||
29 | return ord($code) - ord("A") if $code =~ /[A-Z]/; | ||||
30 | return ord($code) - ord("a") if $code =~ /[a-z]/; | ||||
31 | return ord($code) - ord("0") + 26 if $code =~ /[0-9]/; | ||||
32 | return; | ||||
33 | } | ||||
34 | |||||
35 | sub code_point { | ||||
36 | my $digit = shift; | ||||
37 | return $digit + ord('a') if 0 <= $digit && $digit <= 25; | ||||
38 | return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36; | ||||
39 | die 'NOT COME HERE'; | ||||
40 | } | ||||
41 | |||||
42 | sub adapt { | ||||
43 | my($delta, $numpoints, $firsttime) = @_; | ||||
44 | $delta = $firsttime ? $delta / DAMP : $delta / 2; | ||||
45 | $delta += $delta / $numpoints; | ||||
46 | my $k = 0; | ||||
47 | while ($delta > ((BASE - TMIN) * TMAX) / 2) { | ||||
48 | $delta /= BASE - TMIN; | ||||
49 | $k += BASE; | ||||
50 | } | ||||
51 | return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW)); | ||||
52 | } | ||||
53 | |||||
54 | sub decode_punycode { | ||||
55 | my $code = shift; | ||||
56 | |||||
57 | my $n = INITIAL_N; | ||||
58 | my $i = 0; | ||||
59 | my $bias = INITIAL_BIAS; | ||||
60 | my @output; | ||||
61 | |||||
62 | if ($code =~ s/(.*)$Delimiter//o) { | ||||
63 | push @output, map ord, split //, $1; | ||||
64 | return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o; | ||||
65 | } | ||||
66 | |||||
67 | while ($code) { | ||||
68 | my $oldi = $i; | ||||
69 | my $w = 1; | ||||
70 | LOOP: | ||||
71 | for (my $k = BASE; 1; $k += BASE) { | ||||
72 | my $cp = substr($code, 0, 1, ''); | ||||
73 | my $digit = digit_value($cp); | ||||
74 | defined $digit or return _croak("invalid punycode input"); | ||||
75 | $i += $digit * $w; | ||||
76 | my $t = ($k <= $bias) ? TMIN | ||||
77 | : ($k >= $bias + TMAX) ? TMAX : $k - $bias; | ||||
78 | last LOOP if $digit < $t; | ||||
79 | $w *= (BASE - $t); | ||||
80 | } | ||||
81 | $bias = adapt($i - $oldi, @output + 1, $oldi == 0); | ||||
82 | warn "bias becomes $bias" if $DEBUG; | ||||
83 | $n += $i / (@output + 1); | ||||
84 | $i = $i % (@output + 1); | ||||
85 | splice(@output, $i, 0, $n); | ||||
86 | warn join " ", map sprintf('%04x', $_), @output if $DEBUG; | ||||
87 | $i++; | ||||
88 | } | ||||
89 | return join '', map chr, @output; | ||||
90 | } | ||||
91 | |||||
92 | sub encode_punycode { | ||||
93 | my $input = shift; | ||||
94 | # my @input = split //, $input; # doesn't work in 5.6.x! | ||||
95 | my @input = map substr($input, $_, 1), 0..length($input)-1; | ||||
96 | |||||
97 | my $n = INITIAL_N; | ||||
98 | my $delta = 0; | ||||
99 | my $bias = INITIAL_BIAS; | ||||
100 | |||||
101 | my @output; | ||||
102 | my @basic = grep /$BasicRE/, @input; | ||||
103 | my $h = my $b = @basic; | ||||
104 | push @output, @basic; | ||||
105 | push @output, $Delimiter if $b && $h < @input; | ||||
106 | warn "basic codepoints: (@output)" if $DEBUG; | ||||
107 | |||||
108 | while ($h < @input) { | ||||
109 | my $m = min(grep { $_ >= $n } map ord, @input); | ||||
110 | warn sprintf "next code point to insert is %04x", $m if $DEBUG; | ||||
111 | $delta += ($m - $n) * ($h + 1); | ||||
112 | $n = $m; | ||||
113 | for my $i (@input) { | ||||
114 | my $c = ord($i); | ||||
115 | $delta++ if $c < $n; | ||||
116 | if ($c == $n) { | ||||
117 | my $q = $delta; | ||||
118 | LOOP: | ||||
119 | for (my $k = BASE; 1; $k += BASE) { | ||||
120 | my $t = ($k <= $bias) ? TMIN : | ||||
121 | ($k >= $bias + TMAX) ? TMAX : $k - $bias; | ||||
122 | last LOOP if $q < $t; | ||||
123 | my $cp = code_point($t + (($q - $t) % (BASE - $t))); | ||||
124 | push @output, chr($cp); | ||||
125 | $q = ($q - $t) / (BASE - $t); | ||||
126 | } | ||||
127 | push @output, chr(code_point($q)); | ||||
128 | $bias = adapt($delta, $h + 1, $h == $b); | ||||
129 | warn "bias becomes $bias" if $DEBUG; | ||||
130 | $delta = 0; | ||||
131 | $h++; | ||||
132 | } | ||||
133 | } | ||||
134 | $delta++; | ||||
135 | $n++; | ||||
136 | } | ||||
137 | return join '', @output; | ||||
138 | } | ||||
139 | |||||
140 | sub min { | ||||
141 | my $min = shift; | ||||
142 | for (@_) { $min = $_ if $_ <= $min } | ||||
143 | return $min; | ||||
144 | } | ||||
145 | |||||
146 | 1 | 8µs | 1; | ||
147 | __END__ | ||||
148 | |||||
149 | =head1 NAME | ||||
150 | |||||
151 | URI::_punycode - encodes Unicode string in Punycode | ||||
152 | |||||
153 | =head1 SYNOPSIS | ||||
154 | |||||
155 | use URI::_punycode; | ||||
156 | $punycode = encode_punycode($unicode); | ||||
157 | $unicode = decode_punycode($punycode); | ||||
158 | |||||
159 | =head1 DESCRIPTION | ||||
160 | |||||
161 | URI::_punycode is a module to encode / decode Unicode strings into | ||||
162 | Punycode, an efficient encoding of Unicode for use with IDNA. | ||||
163 | |||||
164 | This module requires Perl 5.6.0 or over to handle UTF8 flagged Unicode | ||||
165 | strings. | ||||
166 | |||||
167 | =head1 FUNCTIONS | ||||
168 | |||||
169 | This module exports following functions by default. | ||||
170 | |||||
171 | =over 4 | ||||
172 | |||||
173 | =item encode_punycode | ||||
174 | |||||
175 | $punycode = encode_punycode($unicode); | ||||
176 | |||||
177 | takes Unicode string (UTF8-flagged variable) and returns Punycode | ||||
178 | encoding for it. | ||||
179 | |||||
180 | =item decode_punycode | ||||
181 | |||||
182 | $unicode = decode_punycode($punycode) | ||||
183 | |||||
184 | takes Punycode encoding and returns original Unicode string. | ||||
185 | |||||
186 | =back | ||||
187 | |||||
188 | These functions throws exceptionsn on failure. You can catch 'em via | ||||
189 | C<eval>. | ||||
190 | |||||
191 | =head1 AUTHOR | ||||
192 | |||||
193 | Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt> is the author of | ||||
194 | IDNA::Punycode v0.02 which was the basis for this module. | ||||
195 | |||||
196 | This library is free software; you can redistribute it and/or modify | ||||
197 | it under the same terms as Perl itself. | ||||
198 | |||||
199 | =head1 SEE ALSO | ||||
200 | |||||
201 | L<IDNA::Punycode>, RFC 3492 | ||||
202 | |||||
203 | =cut | ||||
# spent 6µs within URI::_punycode::CORE:qr which was called
# once (6µs+0s) by URI::_idna::BEGIN@7 at line 23 of URI/_punycode.pm |