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

package Net::IDN::Encode;

require 5.006;

use strict;
use utf8;
use warnings;

our $VERSION = "2.500";
$VERSION = eval $VERSION;

use Carp;
use Exporter;

our @ISA = ('Exporter');
our @EXPORT = ();
our %EXPORT_TAGS = (
  'all'	 => [
      'to_ascii',
      'to_unicode',
      'domain_to_ascii',
      'domain_to_unicode',
      'email_to_ascii',
      'email_to_unicode',
    ],
  '_var' => [
      '$IDNA_PREFIX',
      'IsIDNADot',
      'IsIDNAAtsign',
    ]
);
Exporter::export_ok_tags(keys %EXPORT_TAGS);

use Net::IDN::Punycode 1.102 ();

our $IDNA_PREFIX = 'xn--';
sub IsIDNADot 	{ "002E\n3002\nFF0E\nFF61" }
sub IsIDNAAtsign{ "0040\nFE6B\nFF20" }

require Net::IDN::UTS46; # after declaration of vars!

sub to_ascii {
  my($label,%param) = @_;
  croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o;

  if($label =~ m/\P{ASCII}/o) {
    $label = Net::IDN::UTS46::to_ascii(@_);
  } else {
    croak 'label empty' if length($label) < 1;
    croak 'label too long' if length($label) > 63;
  }
  return $label;
}

sub to_unicode {
  my($label,%param) = @_;
  croak 'Invalid label' if $label =~ m/\p{IsIDNADot}/o;

  if($label =~ m/\P{ASCII}|^(?:(?i)$IDNA_PREFIX)/o) {
    $label = Net::IDN::UTS46::to_unicode(@_);
  }
  return $label;
}

sub _domain {
  my ($domain,$to_function,$ascii,%param) = @_;
  $param{'UseSTD3ASCIIRules'} = 1 unless exists $param{'UseSTD3ASCIIRules'};

  my $even_odd = 1;
  return join '',
    map { $even_odd++ % 2 ? $to_function->($_, %param) : $ascii ? '.' : $_ }
      split /(\p{IsIDNADot})/o, $domain;
}

sub _email {
  my ($email,$to_function,$ascii,%param) = @_;
  return $email if !defined($email) || $email eq '';

  $email =~ m/^(
	(?(?!\p{IsIDNAAtsign}|").|(?!))+
	|
	"(?:(?:[^"]|\\.)*[^\\])?"
      )
      (?:
	(\p{IsIDNAAtsign})
   	(?:([^\[\]]*)|(\[.*\]))?
      )?$/xo || croak "Invalid email address";
  my($local_part,$at,$domain,$domain_literal) = ($1,$2,$3);

  $local_part =~ m/\P{ASCII}/ && croak "Non-ASCII characters in local-part";
  $domain_literal =~ m/\P{ASCII}/ && croak "Non-ASCII characters in domain-literal" if $domain_literal;

  $domain = $to_function->($domain,%param) if $domain;
  $at = '@' if $ascii;

  return ($domain || $domain_literal)
    ? ($local_part.$at.($domain || $domain_literal))
    : ($local_part);
}

sub domain_to_ascii { _domain(shift, \&to_ascii, 1, @_) }
sub domain_to_unicode { _domain(shift, \&to_unicode, 0, @_) }

sub email_to_ascii   { _email(shift, \&domain_to_ascii, 1, @_) }
sub email_to_unicode { _email(shift, \&domain_to_unicode, 0, @_) }

1;

__END__