home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _d89afd61389ab01e20709487ecb69cfd < prev    next >
Encoding:
Text File  |  2004-06-01  |  2.3 KB  |  107 lines
  1. package URI::_server;
  2. require URI::_generic;
  3. @ISA=qw(URI::_generic);
  4.  
  5. use strict;
  6. use URI::Escape qw(uri_unescape);
  7.  
  8. sub 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.  
  28. sub 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.  
  51. sub _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.  
  66. sub 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.  
  74. sub 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.  
  87. sub default_port { undef }
  88.  
  89. sub 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.  
  106. 1;
  107.