You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
106 lines
2.3 KiB
106 lines
2.3 KiB
package URI::_server;
|
|
require URI::_generic;
|
|
@ISA=qw(URI::_generic);
|
|
|
|
use strict;
|
|
use URI::Escape qw(uri_unescape);
|
|
|
|
sub userinfo
|
|
{
|
|
my $self = shift;
|
|
my $old = $self->authority;
|
|
|
|
if (@_) {
|
|
my $new = $old;
|
|
$new = "" unless defined $new;
|
|
$new =~ s/^[^@]*@//; # remove old stuff
|
|
my $ui = shift;
|
|
if (defined $ui) {
|
|
$ui =~ s/@/%40/g; # protect @
|
|
$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; # protect @
|
|
$port = $1 if $new =~ s/(:\d+)$//;
|
|
}
|
|
$self->authority("$ui$new$port");
|
|
}
|
|
return undef unless defined $old;
|
|
$old =~ s/^[^@]*@//;
|
|
$old =~ s/:\d+$//;
|
|
return uri_unescape($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/^[^@]*@//; # zap userinfo
|
|
$old =~ s/:$//; # empty port does not could
|
|
$old .= ":" . $self->port unless $old =~ /:/;
|
|
$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;
|