File Coverage

blib/lib/Net/IDN/Encode.pm
Criterion Covered Total %
statement 53 53 100.0
branch 25 32 78.1
condition 6 12 50.0
subroutine 17 17 100.0
pod 6 8 75.0
total 107 122 87.7


line stmt bran cond sub pod time code
1             package Net::IDN::Encode;
2              
3             require 5.006;
4              
5 12     12   213165 use strict;
  12         63  
  12         329  
6 12     12   1289 use utf8;
  12         47  
  12         60  
7 12     12   293 use warnings;
  12         26  
  12         691  
8              
9             our $VERSION = "2.500";
10             $VERSION = eval $VERSION;
11              
12 12     12   68 use Carp;
  12         23  
  12         741  
13 12     12   73 use Exporter;
  12         24  
  12         1430  
14              
15             our @ISA = ('Exporter');
16             our @EXPORT = ();
17             our %EXPORT_TAGS = (
18             'all' => [
19             'to_ascii',
20             'to_unicode',
21             'domain_to_ascii',
22             'domain_to_unicode',
23             'email_to_ascii',
24             'email_to_unicode',
25             ],
26             '_var' => [
27             '$IDNA_PREFIX',
28             'IsIDNADot',
29             'IsIDNAAtsign',
30             ]
31             );
32             Exporter::export_ok_tags(keys %EXPORT_TAGS);
33              
34 12     12   2091 use Net::IDN::Punycode 1.102 ();
  12         293  
  12         1638  
35              
36             our $IDNA_PREFIX = 'xn--';
37 10     10 0 1522 sub IsIDNADot { "002E\n3002\nFF0E\nFF61" }
38 4     4 0 725 sub IsIDNAAtsign{ "0040\nFE6B\nFF20" }
39              
40             require Net::IDN::UTS46; # after declaration of vars!
41              
42             sub to_ascii {
43 88     88 1 365 my($label,%param) = @_;
44 9 50   9   64 croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o;
  9         15  
  9         116  
  88         297  
45              
46 88 100       564 if($label =~ m/\P{ASCII}/o) {
47 16         58 $label = Net::IDN::UTS46::to_ascii(@_);
48             } else {
49 72 50       158 croak 'label empty' if length($label) < 1;
50 72 50       131 croak 'label too long' if length($label) > 63;
51             }
52 87         412 return $label;
53             }
54              
55             sub to_unicode {
56 91     91 1 206 my($label,%param) = @_;
57 91 50       296 croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o;
58              
59 91 100       635 if($label =~ m/\P{ASCII}|^(?:(?i)$IDNA_PREFIX)/o) {
60 29         244 $label = Net::IDN::UTS46::to_unicode(@_);
61             }
62 89         634 return $label;
63             }
64              
65             sub _domain {
66 56     56   147 my ($domain,$to_function,$ascii,%param) = @_;
67 56 100       169 $param{'UseSTD3ASCIIRules'} = 1 unless exists $param{'UseSTD3ASCIIRules'};
68              
69 56         90 my $even_odd = 1;
70             return join '',
71 56 100       441 map { $even_odd++ % 2 ? $to_function->($_, %param) : $ascii ? '.' : $_ }
  274 100       1218  
72             split /(\p{IsIDNADot})/o, $domain;
73             }
74              
75             sub _email {
76 26     26   65 my ($email,$to_function,$ascii,%param) = @_;
77 26 100 100     150 return $email if !defined($email) || $email eq '';
78              
79 18 50       183 $email =~ m/^(
80             (?(?!\p{IsIDNAAtsign}|").|(?!))+
81             |
82             "(?:(?:[^"]|\\.)*[^\\])?"
83             )
84             (?:
85             (\p{IsIDNAAtsign})
86             (?:([^\[\]]*)|(\[.*\]))?
87             )?$/xo || croak "Invalid email address";
88 18         285 my($local_part,$at,$domain,$domain_literal) = ($1,$2,$3);
89              
90 18 50       55 $local_part =~ m/\P{ASCII}/ && croak "Non-ASCII characters in local-part";
91 18 50 0     41 $domain_literal =~ m/\P{ASCII}/ && croak "Non-ASCII characters in domain-literal" if $domain_literal;
92              
93 18 100       50 $domain = $to_function->($domain,%param) if $domain;
94 18 100       48 $at = '@' if $ascii;
95              
96 18 100 66     146 return ($domain || $domain_literal)
      33        
97             ? ($local_part.$at.($domain || $domain_literal))
98             : ($local_part);
99             }
100              
101 27     27 1 3536 sub domain_to_ascii { _domain(shift, \&to_ascii, 1, @_) }
102 29     29 1 3169 sub domain_to_unicode { _domain(shift, \&to_unicode, 0, @_) }
103              
104 13     13 1 50 sub email_to_ascii { _email(shift, \&domain_to_ascii, 1, @_) }
105 13     13 1 46 sub email_to_unicode { _email(shift, \&domain_to_unicode, 0, @_) }
106              
107             1;
108              
109             __END__