Profile of URI.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/URI.pm
Statements | Executed 27 statements in 1.58ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 728µs | 800µs | URI::::BEGIN@41URI::BEGIN@41
1 | 1 | 1 | 10µs | 11µs | URI::::BEGIN@3URI::BEGIN@3
1 | 1 | 1 | 7µs | 29µs | URI::::BEGIN@43URI::BEGIN@43
1 | 1 | 1 | 6µs | 11µs | URI::::BEGIN@180URI::BEGIN@180
1 | 1 | 1 | 4µs | 27µs | URI::::BEGIN@9URI::BEGIN@9
1 | 1 | 1 | 4µs | 20µs | URI::::BEGIN@4URI::BEGIN@4
1 | 1 | 1 | 2µs | 2µs | URI::::BEGIN@40URI::BEGIN@40
0 | 0 | 0 | 0s | 0s | URI::::STORABLE_freezeURI::STORABLE_freeze
0 | 0 | 0 | 0s | 0s | URI::::STORABLE_thawURI::STORABLE_thaw
0 | 0 | 0 | 0s | 0s | URI::::TO_JSONURI::TO_JSON
0 | 0 | 0 | 0s | 0s | URI::::__ANON__[:43]URI::__ANON__[:43]
0 | 0 | 0 | 0s | 0s | URI::::__ANON__[:44]URI::__ANON__[:44]
0 | 0 | 0 | 0s | 0s | URI::::__ANON__[:45]URI::__ANON__[:45]
0 | 0 | 0 | 0s | 0s | URI::::_fix_uric_escape_for_host_partURI::_fix_uric_escape_for_host_part
0 | 0 | 0 | 0s | 0s | URI::::_initURI::_init
0 | 0 | 0 | 0s | 0s | URI::::_init_implementorURI::_init_implementor
0 | 0 | 0 | 0s | 0s | URI::::_no_scheme_okURI::_no_scheme_ok
0 | 0 | 0 | 0s | 0s | URI::::_obj_eqURI::_obj_eq
0 | 0 | 0 | 0s | 0s | URI::::_schemeURI::_scheme
0 | 0 | 0 | 0s | 0s | URI::::_uric_escapeURI::_uric_escape
0 | 0 | 0 | 0s | 0s | URI::::absURI::abs
0 | 0 | 0 | 0s | 0s | URI::::as_iriURI::as_iri
0 | 0 | 0 | 0s | 0s | URI::::as_stringURI::as_string
0 | 0 | 0 | 0s | 0s | URI::::canonicalURI::canonical
0 | 0 | 0 | 0s | 0s | URI::::cloneURI::clone
0 | 0 | 0 | 0s | 0s | URI::::eqURI::eq
0 | 0 | 0 | 0s | 0s | URI::::fragmentURI::fragment
0 | 0 | 0 | 0s | 0s | URI::::has_recognized_schemeURI::has_recognized_scheme
0 | 0 | 0 | 0s | 0s | URI::::implementorURI::implementor
0 | 0 | 0 | 0s | 0s | URI::::newURI::new
0 | 0 | 0 | 0s | 0s | URI::::new_absURI::new_abs
0 | 0 | 0 | 0s | 0s | URI::::opaqueURI::opaque
0 | 0 | 0 | 0s | 0s | URI::::pathURI::path
0 | 0 | 0 | 0s | 0s | URI::::relURI::rel
0 | 0 | 0 | 0s | 0s | URI::::schemeURI::scheme
0 | 0 | 0 | 0s | 0s | URI::::secureURI::secure

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package URI;
2 |  |  |  |  |
3 | 2 | 24µs | 2 | 13µs | # spent 11µs (10+2) within URI::BEGIN@3 which was called: # once (10µs+2µs) by XML::Twig::_use at line 3 use strict; # spent 11µs making 1 call to URI::BEGIN@3 # spent 2µs making 1 call to strict::import
4 | 2 | 35µs | 2 | 36µs | # spent 20µs (4+16) within URI::BEGIN@4 which was called: # once (4µs+16µs) by XML::Twig::_use at line 4 use warnings; # spent 20µs making 1 call to URI::BEGIN@4 # spent 16µs making 1 call to warnings::import
5 |  |  |  |  |
6 | 1 | 300ns |  |  | our $VERSION = '5.27';
7 |  |  |  |  |
8 |  |  |  |  | # 1=version 5.10 and earlier; 0=version 5.11 and later
9 | 2 | 97µs | 2 | 50µs | # spent 27µs (4+23) within URI::BEGIN@9 which was called: # once (4µs+23µs) by XML::Twig::_use at line 9 use constant HAS_RESERVED_SQUARE_BRACKETS => $ENV{URI_HAS_RESERVED_SQUARE_BRACKETS} ? 1 : 0; # spent 27µs making 1 call to URI::BEGIN@9 # spent 23µs making 1 call to constant::import
10 |  |  |  |  |
11 |  |  |  |  | our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER);
12 |  |  |  |  |
13 | 1 | 200ns |  |  | my %implements; # mapping from scheme to implementor class
14 |  |  |  |  |
15 |  |  |  |  | # Some "official" character classes
16 |  |  |  |  |
17 | 1 | 100ns |  |  | our $reserved = HAS_RESERVED_SQUARE_BRACKETS ? q(;/?:@&=+$,[]) : q(;/?:@&=+$,);
18 | 1 | 100ns |  |  | our $mark = q(-_.!~*'()); #'; emacs
19 | 1 | 700ns |  |  | our $unreserved = "A-Za-z0-9\Q$mark\E";
20 | 1 | 300ns |  |  | our $uric = quotemeta($reserved) . $unreserved . "%";
21 | 1 | 400ns |  |  | our $uric4host = $uric . ( HAS_RESERVED_SQUARE_BRACKETS ? '' : quotemeta( q([]) ) );
22 | 1 | 200ns |  |  | our $uric4user = quotemeta( q{!$'()*,;:._~%-+=%&} ) . "A-Za-z0-9" . ( HAS_RESERVED_SQUARE_BRACKETS ? quotemeta( q([]) ) : '' ); # RFC-3987: iuserinfo w/o UTF
23 |  |  |  |  |
24 | 1 | 100ns |  |  | our $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
25 |  |  |  |  |
26 |  |  |  |  | # These schemes don't have an IPv6+ address part.
27 | 1 | 0s |  |  | our $schemes_without_host_part_re = 'data|ldapi|urn|sqlite|sqlite3';
28 |  |  |  |  |
29 |  |  |  |  | # These schemes can have an IPv6+ authority part:
30 |  |  |  |  | # file, ftp, gopher, http, https, ldap, ldaps, mms, news, nntp, nntps, pop, rlogin, rtsp, rtspu, rsync, sip, sips, snews,
31 |  |  |  |  | # telnet, tn3270, ssh, sftp
32 |  |  |  |  | # (all DB URIs, i.e. cassandra, couch, couchdb, etc.), except 'sqlite:', 'sqlite3:'. Others?
33 |  |  |  |  | #MAINT: URI has no test coverage for DB schemes
34 |  |  |  |  | #MAINT: decoupling - perhaps let each class decide itself by defining a member function 'scheme_has_authority_part()'?
35 |  |  |  |  |
36 |  |  |  |  | #MAINT: 'mailto:' needs special treatment for IPv* addresses / RFC 5321 (4.1.3). Until then: restore all '[', ']'
37 |  |  |  |  | # These schemes need fallback to previous (<= 5.10) encoding until a specific handler is available.
38 | 1 | 100ns |  |  | our $fallback_schemes_re = 'mailto';
39 |  |  |  |  |
40 | 2 | 11µs | 1 | 2µs | # spent 2µs within URI::BEGIN@40 which was called: # once (2µs+0s) by XML::Twig::_use at line 40 use Carp (); # spent 2µs making 1 call to URI::BEGIN@40
41 | 2 | 112µs | 1 | 800µs | # spent 800µs (728+72) within URI::BEGIN@41 which was called: # once (728µs+72µs) by XML::Twig::_use at line 41 use URI::Escape (); # spent 800µs making 1 call to URI::BEGIN@41
42 |  |  |  |  |
43 |  |  |  |  | # spent 29µs (7+22) within URI::BEGIN@43 which was called: # once (7µs+22µs) by XML::Twig::_use at line 47 use overload ('""' => sub { ${$_[0]} },
44 |  |  |  |  | '==' => sub { _obj_eq(@_) },
45 |  |  |  |  | '!=' => sub { !_obj_eq(@_) },
46 | 1 | 5µs | 1 | 22µs | fallback => 1, # spent 22µs making 1 call to overload::import
47 | 1 | 476µs | 1 | 29µs | ); # spent 29µs making 1 call to URI::BEGIN@43
48 |  |  |  |  |
49 |  |  |  |  | # Check if two objects are the same object
50 |  |  |  |  | sub _obj_eq {
51 |  |  |  |  | return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
52 |  |  |  |  | }
53 |  |  |  |  |
54 |  |  |  |  | sub new
55 |  |  |  |  | {
56 |  |  |  |  | my($class, $uri, $scheme) = @_;
57 |  |  |  |  |
58 |  |  |  |  | $uri = defined ($uri) ? "$uri" : ""; # stringify
59 |  |  |  |  | # Get rid of potential wrapping
60 |  |  |  |  | $uri =~ s/^<(?:URL:)?(.*)>$/$1/; #
61 |  |  |  |  | $uri =~ s/^"(.*)"$/$1/;
62 |  |  |  |  | $uri =~ s/^\s+//;
63 |  |  |  |  | $uri =~ s/\s+$//;
64 |  |  |  |  |
65 |  |  |  |  | my $impclass;
66 |  |  |  |  | if ($uri =~ m/^($scheme_re):/so) {
67 |  |  |  |  | $scheme = $1;
68 |  |  |  |  | }
69 |  |  |  |  | else {
70 |  |  |  |  | if (($impclass = ref($scheme))) {
71 |  |  |  |  | $scheme = $scheme->scheme;
72 |  |  |  |  | }
73 |  |  |  |  | elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
74 |  |  |  |  | $scheme = $1;
75 |  |  |  |  | }
76 |  |  |  |  | }
77 |  |  |  |  | $impclass ||= implementor($scheme) ||
78 |  |  |  |  | do {
79 |  |  |  |  | require URI::_foreign;
80 |  |  |  |  | $impclass = 'URI::_foreign';
81 |  |  |  |  | };
82 |  |  |  |  |
83 |  |  |  |  | return $impclass->_init($uri, $scheme);
84 |  |  |  |  | }
85 |  |  |  |  |
86 |  |  |  |  |
87 |  |  |  |  | sub new_abs
88 |  |  |  |  | {
89 |  |  |  |  | my($class, $uri, $base) = @_;
90 |  |  |  |  | $uri = $class->new($uri, $base);
91 |  |  |  |  | $uri->abs($base);
92 |  |  |  |  | }
93 |  |  |  |  |
94 |  |  |  |  |
95 |  |  |  |  | sub _init
96 |  |  |  |  | {
97 |  |  |  |  | my $class = shift;
98 |  |  |  |  | my($str, $scheme) = @_;
99 |  |  |  |  | # find all funny characters and encode the bytes.
100 |  |  |  |  | $str = $class->_uric_escape($str);
101 |  |  |  |  | $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
102 |  |  |  |  | $class->_no_scheme_ok;
103 |  |  |  |  | my $self = bless \$str, $class;
104 |  |  |  |  | $self;
105 |  |  |  |  | }
106 |  |  |  |  |
107 |  |  |  |  |
108 |  |  |  |  | #-- Version: 5.11+
109 |  |  |  |  | # Since the complete URI will be percent-encoded including '[' and ']',
110 |  |  |  |  | # we selectively unescape square brackets from the authority/host part of the URI.
111 |  |  |  |  | # Derived modules that implement _uric_escape() should take this into account
112 |  |  |  |  | # if they do not rely on URI::_uric_escape().
113 |  |  |  |  | # No unescaping is performed for the userinfo@ part of the authority part.
114 |  |  |  |  | sub _fix_uric_escape_for_host_part {
115 |  |  |  |  | return if HAS_RESERVED_SQUARE_BRACKETS;
116 |  |  |  |  | return if $_[0] !~ /%/;
117 |  |  |  |  | return if $_[0] =~ m{^(?:$URI::schemes_without_host_part_re):}os;
118 |  |  |  |  |
119 |  |  |  |  | # until a scheme specific handler is available, fall back to previous behavior of v5.10 (i.e. 'mailto:')
120 |  |  |  |  | if ($_[0] =~ m{^(?:$URI::fallback_schemes_re):}os) {
121 |  |  |  |  | $_[0] =~ s/\%5B/[/gi;
122 |  |  |  |  | $_[0] =~ s/\%5D/]/gi;
123 |  |  |  |  | return;
124 |  |  |  |  | }
125 |  |  |  |  |
126 |  |  |  |  | if ($_[0] =~ m{^((?:$URI::scheme_re:)?)//([^/?\#]+)(.*)$}os) {
127 |  |  |  |  | my $orig = $2;
128 |  |  |  |  | my ($user, $host) = $orig =~ /^(.*@)?([^@]*)$/;
129 |  |  |  |  | $user ||= '';
130 |  |  |  |  | my $port = $host =~ s/(:\d+)$// ? $1 : '';
131 |  |  |  |  | #MAINT: die() here if scheme indicates TCP/UDP and port is out of range [0..65535] ?
132 |  |  |  |  | $host =~ s/\%5B/[/gi;
133 |  |  |  |  | $host =~ s/\%5D/]/gi;
134 |  |  |  |  | $_[0] =~ s/\Q$orig\E/$user$host$port/;
135 |  |  |  |  | }
136 |  |  |  |  | }
137 |  |  |  |  |
138 |  |  |  |  |
139 |  |  |  |  | sub _uric_escape
140 |  |  |  |  | {
141 |  |  |  |  | my($class, $str) = @_;
142 |  |  |  |  | $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
143 |  |  |  |  | _fix_uric_escape_for_host_part( $str );
144 |  |  |  |  | utf8::downgrade($str);
145 |  |  |  |  | return $str;
146 |  |  |  |  | }
147 |  |  |  |  |
148 | 1 | 0s |  |  | my %require_attempted;
149 |  |  |  |  |
150 |  |  |  |  | sub implementor
151 |  |  |  |  | {
152 |  |  |  |  | my($scheme, $impclass) = @_;
153 |  |  |  |  | if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
154 |  |  |  |  | require URI::_generic;
155 |  |  |  |  | return "URI::_generic";
156 |  |  |  |  | }
157 |  |  |  |  |
158 |  |  |  |  | $scheme = lc($scheme);
159 |  |  |  |  |
160 |  |  |  |  | if ($impclass) {
161 |  |  |  |  | # Set the implementor class for a given scheme
162 |  |  |  |  | my $old = $implements{$scheme};
163 |  |  |  |  | $impclass->_init_implementor($scheme);
164 |  |  |  |  | $implements{$scheme} = $impclass;
165 |  |  |  |  | return $old;
166 |  |  |  |  | }
167 |  |  |  |  |
168 |  |  |  |  | my $ic = $implements{$scheme};
169 |  |  |  |  | return $ic if $ic;
170 |  |  |  |  |
171 |  |  |  |  | # scheme not yet known, look for internal or
172 |  |  |  |  | # preloaded (with 'use') implementation
173 |  |  |  |  | $ic = "URI::$scheme"; # default location
174 |  |  |  |  |
175 |  |  |  |  | # turn scheme into a valid perl identifier by a simple transformation...
176 |  |  |  |  | $ic =~ s/\+/_P/g;
177 |  |  |  |  | $ic =~ s/\./_O/g;
178 |  |  |  |  | $ic =~ s/\-/_/g;
179 |  |  |  |  |
180 | 2 | 811µs | 2 | 15µs | # spent 11µs (6+4) within URI::BEGIN@180 which was called: # once (6µs+4µs) by XML::Twig::_use at line 180 no strict 'refs'; # spent 11µs making 1 call to URI::BEGIN@180 # spent 4µs making 1 call to strict::unimport
181 |  |  |  |  | # check we actually have one for the scheme:
182 |  |  |  |  | unless (@{"${ic}::ISA"}) {
183 |  |  |  |  | if (not exists $require_attempted{$ic}) {
184 |  |  |  |  | $require_attempted{$ic} = 1;
185 |  |  |  |  |
186 |  |  |  |  | # Try to load it
187 |  |  |  |  | my $_old_error = $@;
188 |  |  |  |  | eval "require $ic";
189 |  |  |  |  | die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
190 |  |  |  |  | $@ = $_old_error;
191 |  |  |  |  | }
192 |  |  |  |  | return undef unless @{"${ic}::ISA"};
193 |  |  |  |  | }
194 |  |  |  |  |
195 |  |  |  |  | $ic->_init_implementor($scheme);
196 |  |  |  |  | $implements{$scheme} = $ic;
197 |  |  |  |  | $ic;
198 |  |  |  |  | }
199 |  |  |  |  |
200 |  |  |  |  |
201 |  |  |  |  | sub _init_implementor
202 |  |  |  |  | {
203 |  |  |  |  | my($class, $scheme) = @_;
204 |  |  |  |  | # Remember that one implementor class may actually
205 |  |  |  |  | # serve to implement several URI schemes.
206 |  |  |  |  | }
207 |  |  |  |  |
208 |  |  |  |  |
209 |  |  |  |  | sub clone
210 |  |  |  |  | {
211 |  |  |  |  | my $self = shift;
212 |  |  |  |  | my $other = $$self;
213 |  |  |  |  | bless \$other, ref $self;
214 |  |  |  |  | }
215 |  |  |  |  |
216 |  |  |  |  | sub TO_JSON { ${$_[0]} }
217 |  |  |  |  |
218 |  |  |  |  | sub _no_scheme_ok { 0 }
219 |  |  |  |  |
220 |  |  |  |  | sub _scheme
221 |  |  |  |  | {
222 |  |  |  |  | my $self = shift;
223 |  |  |  |  |
224 |  |  |  |  | unless (@_) {
225 |  |  |  |  | return undef unless $$self =~ /^($scheme_re):/o;
226 |  |  |  |  | return $1;
227 |  |  |  |  | }
228 |  |  |  |  |
229 |  |  |  |  | my $old;
230 |  |  |  |  | my $new = shift;
231 |  |  |  |  | if (defined($new) && length($new)) {
232 |  |  |  |  | Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
233 |  |  |  |  | $old = $1 if $$self =~ s/^($scheme_re)://o;
234 |  |  |  |  | my $newself = URI->new("$new:$$self");
235 |  |  |  |  | $$self = $$newself;
236 |  |  |  |  | bless $self, ref($newself);
237 |  |  |  |  | }
238 |  |  |  |  | else {
239 |  |  |  |  | if ($self->_no_scheme_ok) {
240 |  |  |  |  | $old = $1 if $$self =~ s/^($scheme_re)://o;
241 |  |  |  |  | Carp::carp("Oops, opaque part now look like scheme")
242 |  |  |  |  | if $^W && $$self =~ m/^$scheme_re:/o
243 |  |  |  |  | }
244 |  |  |  |  | else {
245 |  |  |  |  | $old = $1 if $$self =~ m/^($scheme_re):/o;
246 |  |  |  |  | }
247 |  |  |  |  | }
248 |  |  |  |  |
249 |  |  |  |  | return $old;
250 |  |  |  |  | }
251 |  |  |  |  |
252 |  |  |  |  | sub scheme
253 |  |  |  |  | {
254 |  |  |  |  | my $scheme = shift->_scheme(@_);
255 |  |  |  |  | return undef unless defined $scheme;
256 |  |  |  |  | lc($scheme);
257 |  |  |  |  | }
258 |  |  |  |  |
259 |  |  |  |  | sub has_recognized_scheme {
260 |  |  |  |  | my $self = shift;
261 |  |  |  |  | return ref($self) !~ /^URI::_(?:foreign|generic)\z/;
262 |  |  |  |  | }
263 |  |  |  |  |
264 |  |  |  |  | sub opaque
265 |  |  |  |  | {
266 |  |  |  |  | my $self = shift;
267 |  |  |  |  |
268 |  |  |  |  | unless (@_) {
269 |  |  |  |  | $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
270 |  |  |  |  | return $1;
271 |  |  |  |  | }
272 |  |  |  |  |
273 |  |  |  |  | $$self =~ /^($scheme_re:)? # optional scheme
274 |  |  |  |  | ([^\#]*) # opaque
275 |  |  |  |  | (\#.*)? # optional fragment
276 |  |  |  |  | $/sx or die;
277 |  |  |  |  |
278 |  |  |  |  | my $old_scheme = $1;
279 |  |  |  |  | my $old_opaque = $2;
280 |  |  |  |  | my $old_frag = $3;
281 |  |  |  |  |
282 |  |  |  |  | my $new_opaque = shift;
283 |  |  |  |  | $new_opaque = "" unless defined $new_opaque;
284 |  |  |  |  | $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
285 |  |  |  |  | utf8::downgrade($new_opaque);
286 |  |  |  |  |
287 |  |  |  |  | $$self = defined($old_scheme) ? $old_scheme : "";
288 |  |  |  |  | $$self .= $new_opaque;
289 |  |  |  |  | $$self .= $old_frag if defined $old_frag;
290 |  |  |  |  |
291 |  |  |  |  | $old_opaque;
292 |  |  |  |  | }
293 |  |  |  |  |
294 |  |  |  |  | sub path { goto &opaque } # alias
295 |  |  |  |  |
296 |  |  |  |  |
297 |  |  |  |  | sub fragment
298 |  |  |  |  | {
299 |  |  |  |  | my $self = shift;
300 |  |  |  |  | unless (@_) {
301 |  |  |  |  | return undef unless $$self =~ /\#(.*)/s;
302 |  |  |  |  | return $1;
303 |  |  |  |  | }
304 |  |  |  |  |
305 |  |  |  |  | my $old;
306 |  |  |  |  | $old = $1 if $$self =~ s/\#(.*)//s;
307 |  |  |  |  |
308 |  |  |  |  | my $new_frag = shift;
309 |  |  |  |  | if (defined $new_frag) {
310 |  |  |  |  | $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
311 |  |  |  |  | utf8::downgrade($new_frag);
312 |  |  |  |  | $$self .= "#$new_frag";
313 |  |  |  |  | }
314 |  |  |  |  | $old;
315 |  |  |  |  | }
316 |  |  |  |  |
317 |  |  |  |  |
318 |  |  |  |  | sub as_string
319 |  |  |  |  | {
320 |  |  |  |  | my $self = shift;
321 |  |  |  |  | $$self;
322 |  |  |  |  | }
323 |  |  |  |  |
324 |  |  |  |  |
325 |  |  |  |  | sub as_iri
326 |  |  |  |  | {
327 |  |  |  |  | my $self = shift;
328 |  |  |  |  | my $str = $$self;
329 |  |  |  |  | if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
330 |  |  |  |  | # All this crap because the more obvious:
331 |  |  |  |  | #
332 |  |  |  |  | # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
333 |  |  |  |  | #
334 |  |  |  |  | # doesn't work before Encode 2.39. Wait for a standard release
335 |  |  |  |  | # to bundle that version.
336 |  |  |  |  |
337 |  |  |  |  | require Encode;
338 |  |  |  |  | my $enc = Encode::find_encoding("UTF-8");
339 |  |  |  |  | my $u = "";
340 |  |  |  |  | while (length $str) {
341 |  |  |  |  | $u .= $enc->decode($str, Encode::FB_QUIET());
342 |  |  |  |  | if (length $str) {
343 |  |  |  |  | # escape next char
344 |  |  |  |  | $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
345 |  |  |  |  | }
346 |  |  |  |  | }
347 |  |  |  |  | $str = $u;
348 |  |  |  |  | }
349 |  |  |  |  | return $str;
350 |  |  |  |  | }
351 |  |  |  |  |
352 |  |  |  |  |
353 |  |  |  |  | sub canonical
354 |  |  |  |  | {
355 |  |  |  |  | # Make sure scheme is lowercased, that we don't escape unreserved chars,
356 |  |  |  |  | # and that we use upcase escape sequences.
357 |  |  |  |  |
358 |  |  |  |  | my $self = shift;
359 |  |  |  |  | my $scheme = $self->_scheme || "";
360 |  |  |  |  | my $uc_scheme = $scheme =~ /[A-Z]/;
361 |  |  |  |  | my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
362 |  |  |  |  | return $self unless $uc_scheme || $esc;
363 |  |  |  |  |
364 |  |  |  |  | my $other = $self->clone;
365 |  |  |  |  | if ($uc_scheme) {
366 |  |  |  |  | $other->_scheme(lc $scheme);
367 |  |  |  |  | }
368 |  |  |  |  | if ($esc) {
369 |  |  |  |  | $$other =~ s{%([0-9a-fA-F]{2})}
370 |  |  |  |  | { my $a = chr(hex($1));
371 |  |  |  |  | $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
372 |  |  |  |  | }ge;
373 |  |  |  |  | }
374 |  |  |  |  | return $other;
375 |  |  |  |  | }
376 |  |  |  |  |
377 |  |  |  |  | # Compare two URIs, subclasses will provide a more correct implementation
378 |  |  |  |  | sub eq {
379 |  |  |  |  | my($self, $other) = @_;
380 |  |  |  |  | $self = URI->new($self, $other) unless ref $self;
381 |  |  |  |  | $other = URI->new($other, $self) unless ref $other;
382 |  |  |  |  | ref($self) eq ref($other) && # same class
383 |  |  |  |  | $self->canonical->as_string eq $other->canonical->as_string;
384 |  |  |  |  | }
385 |  |  |  |  |
386 |  |  |  |  | # generic-URI transformation methods
387 |  |  |  |  | sub abs { $_[0]; }
388 |  |  |  |  | sub rel { $_[0]; }
389 |  |  |  |  |
390 |  |  |  |  | sub secure { 0 }
391 |  |  |  |  |
392 |  |  |  |  | # help out Storable
393 |  |  |  |  | sub STORABLE_freeze {
394 |  |  |  |  | my($self, $cloning) = @_;
395 |  |  |  |  | return $$self;
396 |  |  |  |  | }
397 |  |  |  |  |
398 |  |  |  |  | sub STORABLE_thaw {
399 |  |  |  |  | my($self, $cloning, $str) = @_;
400 |  |  |  |  | $$self = $str;
401 |  |  |  |  | }
402 |  |  |  |  |
403 | 1 | 4µs |  |  | 1;
404 |  |  |  |  |
405 |  |  |  |  | __END__