File Coverage

blib/lib/URI/Escape/XS.pm

Criterion	Covered	Total	%
statement	31	33	93.9
branch	9	12	75.0
condition			n/a
subroutine	7	7	100.0
pod	2	2	100.0
total	49	54	90.7

package URI::Escape::XS;
#
# $Id: XS.pm,v 0.14 2016/06/09 11:09:14 dankogai Exp $
#
use 5.008001;
use warnings;
use strict;
our $VERSION = sprintf "%d.%02d", q$Revision: 0.14 $ =~ /(\d+)/g;

use base qw(Exporter);
our @EXPORT    = qw(encodeURIComponent decodeURIComponent
		    encodeURIComponentIDN decodeURIComponentIDN);
our @EXPORT_OK = qw(uri_escape uri_unescape);

require XSLoader;
XSLoader::load('URI::Escape::XS', $VERSION);


sub uri_unescape {
    wantarray
	? map { decodeURIComponent($_) } @_
	: decodeURIComponent(shift)
}

{
    use bytes;
    my %escapes = map { chr($_) => sprintf("%%%02X", $_) } (0..255);
    my %regexp;
    sub uri_escape {
	return unless @_;
	my ($text, $patn) = @_;
	return undef unless defined $text;
	$text .= '';    # RT#39344 -- force string
	if (defined $patn){
	    unless (exists $regexp{$patn}){
		my $re;
		eval {
		    $re = qr/[$patn]/;
		};
		if ($@){
		    require Carp;
		    Carp::croak(__PACKAGE__, $@);
		}
		$regexp{$patn} = $re;
	    }
	    $text =~ s/($regexp{$patn})/$escapes{$1}/ge;
	    return $text;
	} else {
	    return encodeURIComponent($text);
	}
    }
}


eval { require Net::LibIDN };
if ( !$@ ) {
    require Encode;
    *decodeURIComponentIDN = sub ($) {
        my $uri = Encode::decode_utf8( decodeURIComponent(shift) );
        $uri =~ s{\A (https?://)([^/:]+)(:[\d]+)?(.*) }
		 {
		     $1
		     . Encode::decode_utf8(
		         Net::LibIDN::idn_to_unicode($2, 'utf-8')
		     )
		     . ($3||'')
		     . $4;
		 }msex;
        return $uri;
    };

    *encodeURIComponentIDN = sub ($) {
        my $uri = shift;
        $uri =~ s{\A (https?)://([^/:]+)(:[\d]+)?(.*) }
		 {
		     $1 . ":%2F%2F"
			 . Net::LibIDN::idn_to_ascii($2, 'utf-8') . ($3||'')
			     . encodeURIComponent($4);
		 }msex;
        return $uri;
    };

}
else {
    eval { require Net::IDN::Encode };
    if ( !$@ ) {
        require Encode;
        *decodeURIComponentIDN = sub ($) {
            my $uri = Encode::decode_utf8( decodeURIComponent(shift) );
            $uri =~ s{\A (https?://)([^/:]+)(:[\d]+)?(.*) }
		 {
		     $1
			 . Net::IDN::Encode::domain_to_unicode($2) . ($3||'')
			     . $4;
		 }msex;
            return $uri;
        };

        *encodeURIComponentIDN = sub ($) {
            my $uri = shift;
            $uri =~ s{\A (https?)://([^/:]+)(:[\d]+)?(.*) }
		 {
		     $1 . ":%2F%2F"
			 . Net::IDN::Encode::domain_to_ascii($2) . ($3||'')
			     . encodeURIComponent($4);
		 }msex;
            return $uri;
        };
    }
}
1;
__END__