local-lib5/lib/perl5/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 _uric_escape {
   9     my($class, $str) = @_;
  10     if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
  11         my($scheme, $host, $rest) = ($1, $2, $3);
  12         my $ui = $host =~ s/(.*@)// ? $1 : "";
  13         my $port = $host =~ s/(:\d+)\z// ? $1 : "";
  14         if (_host_escape($host)) {
  15             $str = "$scheme//$ui$host$port$rest";
  16         }
  17     }
  18     return $class->SUPER::_uric_escape($str);
  19 }
  20
  21 sub _host_escape {
  22     return unless $_[0] =~ /[^URI::uric]/;
  23     require URI::_idna;
  24     $_[0] = URI::_idna::encode($_[0]);
  25     return 1;
  26 }
  27
  28 sub as_iri {
  29     my $self = shift;
  30     my $str = $self->SUPER::as_iri;
  31     if ($str =~ /\bxn--/) {
  32         if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
  33             my($scheme, $host, $rest) = ($1, $2, $3);
  34             my $ui = $host =~ s/(.*@)// ? $1 : "";
  35             my $port = $host =~ s/(:\d+)\z// ? $1 : "";
  36             require URI::_idna;
  37             $host = URI::_idna::encode($host);
  38             $str = "$scheme//$ui$host$port$rest";
  39         }
  40     }
  41     return $str;
  42 }
  43
  44 sub userinfo
  45 {
  46     my $self = shift;
  47     my $old = $self->authority;
  48
  49     if (@_) {
  50         my $new = $old;
  51         $new = "" unless defined $new;
  52         $new =~ s/.*@//;  # remove old stuff
  53         my $ui = shift;
  54         if (defined $ui) {
  55             $ui =~ s/@/%40/g;   # protect @
  56             $new = "$ui\@$new";
  57         }
  58         $self->authority($new);
  59     }
  60     return undef if !defined($old) || $old !~ /(.*)@/;
  61     return $1;
  62 }
  63
  64 sub host
  65 {
  66     my $self = shift;
  67     my $old = $self->authority;
  68     if (@_) {
  69         my $tmp = $old;
  70         $tmp = "" unless defined $tmp;
  71         my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
  72         my $port = ($tmp =~ /(:\d+)$/) ? $1 : "";
  73         my $new = shift;
  74         $new = "" unless defined $new;
  75         if (length $new) {
  76             $new =~ s/[@]/%40/g;   # protect @
  77             if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) {
  78                 $new =~ s/(:\d*)\z// || die "Assert";
  79                 $port = $1;
  80             }
  81             $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address
  82             _host_escape($new);
  83         }
  84         $self->authority("$ui$new$port");
  85     }
  86     return undef unless defined $old;
  87     $old =~ s/.*@//;
  88     $old =~ s/:\d+$//;          # remove the port
  89     $old =~ s{^\[(.*)\]$}{$1};  # remove brackets around IPv6 (RFC 3986 3.2.2)
  90     return uri_unescape($old);
  91 }
  92
  93 sub ihost
  94 {
  95     my $self = shift;
  96     my $old = $self->host(@_);
  97     if ($old =~ /(^|\.)xn--/) {
  98         require URI::_idna;
  99         $old = URI::_idna::decode($old);
 100     }
 101     return $old;
 102 }
 103
 104 sub _port
 105 {
 106     my $self = shift;
 107     my $old = $self->authority;
 108     if (@_) {
 109         my $new = $old;
 110         $new =~ s/:\d*$//;
 111         my $port = shift;
 112         $new .= ":$port" if defined $port;
 113         $self->authority($new);
 114     }
 115     return $1 if defined($old) && $old =~ /:(\d*)$/;
 116     return;
 117 }
 118
 119 sub port
 120 {
 121     my $self = shift;
 122     my $port = $self->_port(@_);
 123     $port = $self->default_port if !defined($port) || $port eq "";
 124     $port;
 125 }
 126
 127 sub host_port
 128 {
 129     my $self = shift;
 130     my $old = $self->authority;
 131     $self->host(shift) if @_;
 132     return undef unless defined $old;
 133     $old =~ s/.*@//;        # zap userinfo
 134     $old =~ s/:$//;         # empty port should be treated the same a no port
 135     $old .= ":" . $self->port unless $old =~ /:\d+$/;
 136     $old;
 137 }
 138
 139
 140 sub default_port { undef }
 141
 142 sub canonical
 143 {
 144     my $self = shift;
 145     my $other = $self->SUPER::canonical;
 146     my $host = $other->host || "";
 147     my $port = $other->_port;
 148     my $uc_host = $host =~ /[A-Z]/;
 149     my $def_port = defined($port) && ($port eq "" ||
 150                                       $port == $self->default_port);
 151     if ($uc_host || $def_port) {
 152         $other = $other->clone if $other == $self;
 153         $other->host(lc $host) if $uc_host;
 154         $other->port(undef)    if $def_port;
 155     }
 156     $other;
 157 }
 158
 159 1;