1package URI::_server; 2require URI::_generic; 3@ISA=qw(URI::_generic); 4 5use strict; 6use URI::Escape qw(uri_unescape); 7 8sub userinfo 9{ 10 my $self = shift; 11 my $old = $self->authority; 12 13 if (@_) { 14 my $new = $old; 15 $new = "" unless defined $new; 16 $new =~ s/.*@//; # remove old stuff 17 my $ui = shift; 18 if (defined $ui) { 19 $ui =~ s/@/%40/g; # protect @ 20 $new = "$ui\@$new"; 21 } 22 $self->authority($new); 23 } 24 return undef if !defined($old) || $old !~ /(.*)@/; 25 return $1; 26} 27 28sub host 29{ 30 my $self = shift; 31 my $old = $self->authority; 32 if (@_) { 33 my $tmp = $old; 34 $tmp = "" unless defined $tmp; 35 my $ui = ($tmp =~ /(.*@)/) ? $1 : ""; 36 my $port = ($tmp =~ /(:\d+)$/) ? $1 : ""; 37 my $new = shift; 38 $new = "" unless defined $new; 39 if (length $new) { 40 $new =~ s/[@]/%40/g; # protect @ 41 $port = $1 if $new =~ s/(:\d+)$//; 42 } 43 $self->authority("$ui$new$port"); 44 } 45 return undef unless defined $old; 46 $old =~ s/.*@//; 47 $old =~ s/:\d+$//; 48 return uri_unescape($old); 49} 50 51sub _port 52{ 53 my $self = shift; 54 my $old = $self->authority; 55 if (@_) { 56 my $new = $old; 57 $new =~ s/:\d*$//; 58 my $port = shift; 59 $new .= ":$port" if defined $port; 60 $self->authority($new); 61 } 62 return $1 if defined($old) && $old =~ /:(\d*)$/; 63 return; 64} 65 66sub port 67{ 68 my $self = shift; 69 my $port = $self->_port(@_); 70 $port = $self->default_port if !defined($port) || $port eq ""; 71 $port; 72} 73 74sub host_port 75{ 76 my $self = shift; 77 my $old = $self->authority; 78 $self->host(shift) if @_; 79 return undef unless defined $old; 80 $old =~ s/.*@//; # zap userinfo 81 $old =~ s/:$//; # empty port does not could 82 $old .= ":" . $self->port unless $old =~ /:/; 83 $old; 84} 85 86 87sub default_port { undef } 88 89sub canonical 90{ 91 my $self = shift; 92 my $other = $self->SUPER::canonical; 93 my $host = $other->host || ""; 94 my $port = $other->_port; 95 my $uc_host = $host =~ /[A-Z]/; 96 my $def_port = defined($port) && ($port eq "" || 97 $port == $self->default_port); 98 if ($uc_host || $def_port) { 99 $other = $other->clone if $other == $self; 100 $other->host(lc $host) if $uc_host; 101 $other->port(undef) if $def_port; 102 } 103 $other; 104} 105 1061; 107