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