git.maemo.org Git - pkg-perl/blob - deb-src/liburi-perl/liburi-perl-1.35.dfsg.1/URI/_server.pm

   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;