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   212463 use strict;
  12         60  
  12         339  
6 12     12   1245 use utf8;
  12         49  
  12         65  
7 12     12   295 use warnings;
  12         22  
  12         657  
8              
9             our $VERSION = "2.499_20180929";
10             $VERSION = eval $VERSION;
11              
12 12     12   75 use Carp;
  12         24  
  12         639  
13 12     12   115 use Exporter;
  12         27  
  12         1389  
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   2070 use Net::IDN::Punycode 1.102 ();
  12         230  
  12         1595  
35              
36             our $IDNA_PREFIX = 'xn--';
37 10     10 0 1447 sub IsIDNADot { "002E\n3002\nFF0E\nFF61" }
38 4     4 0 690 sub IsIDNAAtsign{ "0040\nFE6B\nFF20" }
39              
40             require Net::IDN::UTS46; # after declaration of vars!
41              
42             sub to_ascii {
43 88     88 1 369 my($label,%param) = @_;
44 9 50   9   64 croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o;
  9         26  
  9         110  
  88         301  
45              
46 88 100       555 if($label =~ m/\P{ASCII}/o) {
47 16         57 $label = Net::IDN::UTS46::to_ascii(@_);
48             } else {
49 72 50       156 croak 'label empty' if length($label) < 1;
50 72 50       133 croak 'label too long' if length($label) > 63;
51             }
52 87         384 return $label;
53             }
54              
55             sub to_unicode {
56 91     91 1 217 my($label,%param) = @_;
57 91 50       302 croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o;
58              
59 91 100       658 if($label =~ m/\P{ASCII}|^(?:(?i)$IDNA_PREFIX)/o) {
60 29         242 $label = Net::IDN::UTS46::to_unicode(@_);
61             }
62 89         662 return $label;
63             }
64              
65             sub _domain {
66 56     56   147 my ($domain,$to_function,$ascii,%param) = @_;
67 56 100       184 $param{'UseSTD3ASCIIRules'} = 1 unless exists $param{'UseSTD3ASCIIRules'};
68              
69 56         89 my $even_odd = 1;
70             return join '',
71 56 100       449 map { $even_odd++ % 2 ? $to_function->($_, %param) : $ascii ? '.' : $_ }
  274 100       1271  
72             split /(\p{IsIDNADot})/o, $domain;
73             }
74              
75             sub _email {
76 26     26   99 my ($email,$to_function,$ascii,%param) = @_;
77 26 100 100     196 return $email if !defined($email) || $email eq '';
78              
79 18 50       186 $email =~ m/^(
80             (?(?!\p{IsIDNAAtsign}|").|(?!))+
81             |
82             "(?:(?:[^"]|\\.)*[^\\])?"
83             )
84             (?:
85             (\p{IsIDNAAtsign})
86             (?:([^\[\]]*)|(\[.*\]))?
87             )?$/xo || croak "Invalid email address";
88 18         305 my($local_part,$at,$domain,$domain_literal) = ($1,$2,$3);
89              
90 18 50       53 $local_part =~ m/\P{ASCII}/ && croak "Non-ASCII characters in local-part";
91 18 50 0     37 $domain_literal =~ m/\P{ASCII}/ && croak "Non-ASCII characters in domain-literal" if $domain_literal;
92              
93 18 100       92 $domain = $to_function->($domain,%param) if $domain;
94 18 100       75 $at = '@' if $ascii;
95              
96 18 100 66     134 return ($domain || $domain_literal)
      33        
97             ? ($local_part.$at.($domain || $domain_literal))
98             : ($local_part);
99             }
100              
101 27     27 1 3515 sub domain_to_ascii { _domain(shift, \&to_ascii, 1, @_) }
102 29     29 1 3094 sub domain_to_unicode { _domain(shift, \&to_unicode, 0, @_) }
103              
104 13     13 1 80 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__