File Coverage

blib/lib/Encode/Bootstring.pm
Criterion Covered Total %
statement 142 168 84.5
branch 46 70 65.7
condition 11 21 52.3
subroutine 12 15 80.0
pod 2 10 20.0
total 213 284 75.0


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