home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 May / Chip_2000-05_cd1.bin / zkuste / Perl / ActivePerl-5.6.0.613.msi / 䆊䌷䈹䈙䏵-䞅䞆䞀㡆䞃䄦䠥 / _b7540e86185a3f466313d8502ca9345c < prev    next >
Encoding:
Text File  |  2000-03-15  |  2.3 KB  |  106 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;
  36.     $ui = $1 if $tmp =~ s/^([^@]*@)//;
  37.     $tmp =~ s/^[^:]*//;        # get rid of old host
  38.     my $new = shift;
  39.     if (defined $new) {
  40.         $new =~ s/[@]/%40/g;   # protect @
  41.         $tmp = ($new =~ /:/) ? $new : "$new$tmp";
  42.     }
  43.     $tmp = "$ui$tmp" if defined $ui;
  44.     $self->authority($tmp);
  45.     }
  46.     return undef if !defined($old) || $old !~ /^(?:[^@]*@)?([^:]*)/;
  47.     return uri_unescape($1);
  48. }
  49.  
  50. sub _port
  51. {
  52.     my $self = shift;
  53.     my $old = $self->authority;
  54.     if (@_) {
  55.     my $new = $old;
  56.     $new =~ s/:\d*$//;
  57.     my $port = shift;
  58.     $new .= ":$port" if defined $port;
  59.     $self->authority($new);
  60.     }
  61.     return $1 if defined($old) && $old =~ /:(\d*)$/;
  62.     return;
  63. }
  64.  
  65. sub port
  66. {
  67.     my $self = shift;
  68.     my $port = $self->_port(@_);
  69.     $port = $self->default_port if !defined($port) || $port eq "";
  70.     $port;
  71. }
  72.  
  73. sub host_port
  74. {
  75.     my $self = shift;
  76.     my $old = $self->authority;
  77.     $self->host(shift) if @_;
  78.     return undef unless defined $old;
  79.     $old =~ s/^[^@]*@//;    # zap userinfo
  80.     $old =~ s/:$//;         # empty port does not could
  81.     $old .= ":" . $self->port unless $old =~ /:/;
  82.     $old;
  83. }
  84.  
  85.  
  86. sub default_port { undef }
  87.  
  88. sub canonical
  89. {
  90.     my $self = shift;
  91.     my $other = $self->SUPER::canonical;
  92.     my $host = $other->host || "";
  93.     my $port = $other->_port;
  94.     my $uc_host = $host =~ /[A-Z]/;
  95.     my $def_port = defined($port) && ($port eq "" ||
  96.                                       $port == $self->default_port);
  97.     if ($uc_host || $def_port) {
  98.     $other = $other->clone if $other == $self;
  99.     $other->host(lc $host) if $uc_host;
  100.     $other->port(undef)    if $def_port;
  101.     }
  102.     $other;
  103. }
  104.  
  105. 1;
  106.