File Coverage

blib/lib/URI/Escape/XS.pm
Criterion Covered Total %
statement 32 34 94.1
branch 9 12 75.0
condition n/a
subroutine 7 7 100.0
pod 2 2 100.0
total 50 55 90.9


line stmt bran cond sub pod time code
1             package URI::Escape::XS;
2             #
3             # $Id: XS.pm,v 0.13 2015/06/27 00:28:14 dankogai Exp $
4             #
5 7     7   21973 use 5.008001;
  7         16  
  7         239  
6 7     7   28 use warnings;
  7         8  
  7         172  
7 7     7   27 use strict;
  7         14  
  7         570  
8             our $VERSION = sprintf "%d.%02d", q$Revision: 0.13 $ =~ /(\d+)/g;
9              
10 7     7   35 use base qw(Exporter);
  7         7  
  7         1371  
11             our @EXPORT = qw(encodeURIComponent decodeURIComponent
12             encodeURIComponentIDN decodeURIComponentIDN);
13             our @EXPORT_OK = qw(uri_escape uri_unescape);
14              
15             require XSLoader;
16             XSLoader::load('URI::Escape::XS', $VERSION);
17              
18              
19             sub uri_unescape {
20             wantarray
21 2 100   2 1 14 ? map { decodeURIComponent($_) } @_
  3         13  
22             : decodeURIComponent(shift)
23             }
24              
25             {
26 7     7   4587 use bytes;
  7         63  
  7         27  
27             my %escapes = map { chr($_) => sprintf("%%%02X", $_) } (0..255);
28             my %regexp;
29             sub uri_escape {
30 5 50   5 1 724 return unless @_;
31 5         9 my ($text, $patn) = @_;
32 5 100       16 return undef unless defined $text;
33 4         8 $text .= ''; # RT#39344 -- force string
34 4 100       8 if (defined $patn){
35 1 50       5 unless (exists $regexp{$patn}){
36 1         1 my $re;
37 1         3 eval {
38 1         22 $re = qr/[$patn]/;
39             };
40 1 50       3 if ($@){
41 0         0 require Carp;
42 0         0 Carp::croak(__PACKAGE__, $@);
43             }
44 1         3 $regexp{$patn} = $re;
45             }
46 1         16 $text =~ s/($regexp{$patn})/$escapes{$1}/ge;
  2         7  
47 1         5 return $text;
48             } else {
49 3         20 return encodeURIComponent($text);
50             }
51             }
52             }
53              
54              
55             eval { require Net::LibIDN };
56             if ( !$@ ) {
57             require Encode;
58             *decodeURIComponentIDN = sub ($) {
59             my $uri = Encode::decode_utf8( decodeURIComponent(shift) );
60             $uri =~ s{\A (https?://)([^/:]+)(:[\d]+)?(.*) }
61             {
62             $1
63             . Encode::decode_utf8(
64             Net::LibIDN::idn_to_unicode($2, 'utf-8')
65             )
66             . ($3||'')
67             . $4;
68             }msex;
69             return $uri;
70             };
71              
72             *encodeURIComponentIDN = sub ($) {
73             my $uri = shift;
74             $uri =~ s{\A (https?)://([^/:]+)(:[\d]+)?(.*) }
75             {
76             $1 . ":%2F%2F"
77             . Net::LibIDN::idn_to_ascii($2, 'utf-8') . ($3||'')
78             . encodeURIComponent($4);
79             }msex;
80             return $uri;
81             };
82              
83             }
84             else {
85             eval { require Net::IDN::Encode };
86             if ( !$@ ) {
87             require Encode;
88             *decodeURIComponentIDN = sub ($) {
89             my $uri = Encode::decode_utf8( decodeURIComponent(shift) );
90             $uri =~ s{\A (https?://)([^/:]+)(:[\d]+)?(.*) }
91             {
92             $1
93             . Net::IDN::Encode::domain_to_unicode($2) . ($3||'')
94             . $4;
95             }msex;
96             return $uri;
97             };
98              
99             *encodeURIComponentIDN = sub ($) {
100             my $uri = shift;
101             $uri =~ s{\A (https?)://([^/:]+)(:[\d]+)?(.*) }
102             {
103             $1 . ":%2F%2F"
104             . Net::IDN::Encode::domain_to_ascii($2) . ($3||'')
105             . encodeURIComponent($4);
106             }msex;
107             return $uri;
108             };
109             }
110             }
111             1;
112             __END__