our
$VERSION
=
'5.32'
;
sub
_uric_escape {
my
(
$class
,
$str
) =
@_
;
if
(
$str
=~ m,^((?:
$URI::scheme_re
:)?)//([^/?\
my
(
$scheme
,
$host
,
$rest
) = ($1, $2, $3);
my
$ui
=
$host
=~ s/(.*@)// ? $1 :
""
;
my
$port
=
$host
=~ s/(:\d+)\z// ? $1 :
""
;
if
(_host_escape(
$host
)) {
$str
=
"$scheme//$ui$host$port$rest"
;
}
}
return
$class
->SUPER::_uric_escape(
$str
);
}
sub
_host_escape {
return
if
URI::HAS_RESERVED_SQUARE_BRACKETS and
$_
[0] !~ /[^
$URI::uric
]/;
return
if
!URI::HAS_RESERVED_SQUARE_BRACKETS and
$_
[0] !~ /[^
$URI::uric4host
]/;
eval
{
$_
[0] = URI::_idna::encode(
$_
[0]);
};
return
0
if
$@;
return
1;
}
sub
as_iri {
my
$self
=
shift
;
my
$str
=
$self
->SUPER::as_iri;
if
(
$str
=~ /\bxn--/) {
if
(
$str
=~ m,^((?:
$URI::scheme_re
:)?)//([^/?\
my
(
$scheme
,
$host
,
$rest
) = ($1, $2, $3);
my
$ui
=
$host
=~ s/(.*@)// ? $1 :
""
;
my
$port
=
$host
=~ s/(:\d+)\z// ? $1 :
""
;
$host
= URI::_idna::decode(
$host
);
$str
=
"$scheme//$ui$host$port$rest"
;
}
}
return
$str
;
}
sub
userinfo
{
my
$self
=
shift
;
my
$old
=
$self
->authority;
if
(
@_
) {
my
$new
=
$old
;
$new
=
""
unless
defined
$new
;
$new
=~ s/.*@//;
my
$ui
=
shift
;
if
(
defined
$ui
) {
$ui
=~ s/([^
$URI::uric4user
])/ URI::Escape::escape_char($1)/ego;
$new
=
"$ui\@$new"
;
}
$self
->authority(
$new
);
}
return
undef
if
!
defined
(
$old
) ||
$old
!~ /(.*)@/;
return
$1;
}
sub
host
{
my
$self
=
shift
;
my
$old
=
$self
->authority;
if
(
@_
) {
my
$tmp
=
$old
;
$tmp
=
""
unless
defined
$tmp
;
my
$ui
= (
$tmp
=~ /(.*@)/) ? $1 :
""
;
my
$port
= (
$tmp
=~ /(:\d+)$/) ? $1 :
""
;
my
$new
=
shift
;
$new
=
""
unless
defined
$new
;
if
(
length
$new
) {
$new
=~ s/[@]/%40/g;
if
(
$new
=~ /^[^:]*:\d*\z/ ||
$new
=~ /]:\d*\z/) {
$new
=~ s/(:\d*)\z// ||
die
"Assert"
;
$port
= $1;
}
$new
=
"[$new]"
if
$new
=~ /:/ &&
$new
!~ /^\[/;
_host_escape(
$new
);
}
$self
->authority(
"$ui$new$port"
);
}
return
undef
unless
defined
$old
;
$old
=~ s/.*@//;
$old
=~ s/:\d+$//;
$old
=~ s{^\[(.*)\]$}{$1};
return
uri_unescape(
$old
);
}
sub
ihost
{
my
$self
=
shift
;
my
$old
=
$self
->host(
@_
);
if
(
$old
=~ /(^|\.)xn--/) {
$old
= URI::_idna::decode(
$old
);
}
return
$old
;
}
sub
_port
{
my
$self
=
shift
;
my
$old
=
$self
->authority;
if
(
@_
) {
my
$new
=
$old
;
$new
=~ s/:\d*$//;
my
$port
=
shift
;
$new
.=
":$port"
if
defined
$port
;
$self
->authority(
$new
);
}
return
$1
if
defined
(
$old
) &&
$old
=~ /:(\d*)$/;
return
;
}
sub
port
{
my
$self
=
shift
;
my
$port
=
$self
->_port(
@_
);
$port
=
$self
->default_port
if
!
defined
(
$port
) ||
$port
eq
""
;
$port
;
}
sub
host_port
{
my
$self
=
shift
;
my
$old
=
$self
->authority;
$self
->host(
shift
)
if
@_
;
return
undef
unless
defined
$old
;
$old
=~ s/.*@//;
$old
=~ s/:$//;
$old
.=
":"
.
$self
->port
unless
$old
=~ /:\d+$/;
$old
;
}
sub
default_port {
undef
}
sub
canonical
{
my
$self
=
shift
;
my
$other
=
$self
->SUPER::canonical;
my
$host
=
$other
->host ||
""
;
my
$port
=
$other
->_port;
my
$uc_host
=
$host
=~ /[A-Z]/;
my
$def_port
=
defined
(
$port
) && (
$port
eq
""
||
$port
==
$self
->default_port);
if
(
$uc_host
||
$def_port
) {
$other
=
$other
->clone
if
$other
==
$self
;
$other
->host(
lc
$host
)
if
$uc_host
;
$other
->port(
undef
)
if
$def_port
;
}
$other
;
}
1;