"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/site/lib/URI/_server.pm" (10 Mar 2019, 3724 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

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