summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/URI/_server.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/URI/_server.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/URI/_server.pm162
1 files changed, 162 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/URI/_server.pm b/Master/tlpkg/tlperl/lib/URI/_server.pm
new file mode 100644
index 00000000000..f72ec22657b
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/URI/_server.pm
@@ -0,0 +1,162 @@
+package URI::_server;
+require URI::_generic;
+@ISA=qw(URI::_generic);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+sub _uric_escape {
+ my($class, $str) = @_;
+ if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+ my($scheme, $host, $rest) = ($1, $2, $3);
+ my $ui = $host =~ s/(.*@)// ? $1 : "";
+ my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+ if (_host_escape($host)) {
+ $str = "$scheme//$ui$host$port$rest";
+ }
+ }
+ return $class->SUPER::_uric_escape($str);
+}
+
+sub _host_escape {
+ return unless $_[0] =~ /[^URI::uric]/;
+ eval {
+ require URI::_idna;
+ $_[0] = URI::_idna::encode($_[0]);
+ };
+ return 0 if $@;
+ return 1;
+}
+
+sub as_iri {
+ my $self = shift;
+ my $str = $self->SUPER::as_iri;
+ if ($str =~ /\bxn--/) {
+ if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+ my($scheme, $host, $rest) = ($1, $2, $3);
+ my $ui = $host =~ s/(.*@)// ? $1 : "";
+ my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+ require URI::_idna;
+ $host = URI::_idna::decode($host);
+ $str = "$scheme//$ui$host$port$rest";
+ }
+ }
+ return $str;
+}
+
+sub userinfo
+{
+ my $self = shift;
+ my $old = $self->authority;
+
+ if (@_) {
+ my $new = $old;
+ $new = "" unless defined $new;
+ $new =~ s/.*@//; # remove old stuff
+ my $ui = shift;
+ if (defined $ui) {
+ $ui =~ s/@/%40/g; # protect @
+ $new = "$ui\@$new";
+ }
+ $self->authority($new);
+ }
+ return undef if !defined($old) || $old !~ /(.*)@/;
+ return $1;
+}
+
+sub host
+{
+ my $self = shift;
+ my $old = $self->authority;
+ if (@_) {
+ my $tmp = $old;
+ $tmp = "" unless defined $tmp;
+ my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
+ my $port = ($tmp =~ /(:\d+)$/) ? $1 : "";
+ my $new = shift;
+ $new = "" unless defined $new;
+ if (length $new) {
+ $new =~ s/[@]/%40/g; # protect @
+ if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) {
+ $new =~ s/(:\d*)\z// || die "Assert";
+ $port = $1;
+ }
+ $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address
+ _host_escape($new);
+ }
+ $self->authority("$ui$new$port");
+ }
+ return undef unless defined $old;
+ $old =~ s/.*@//;
+ $old =~ s/:\d+$//; # remove the port
+ $old =~ s{^\[(.*)\]$}{$1}; # remove brackets around IPv6 (RFC 3986 3.2.2)
+ return uri_unescape($old);
+}
+
+sub ihost
+{
+ my $self = shift;
+ my $old = $self->host(@_);
+ if ($old =~ /(^|\.)xn--/) {
+ require URI::_idna;
+ $old = URI::_idna::decode($old);
+ }
+ return $old;
+}
+
+sub _port
+{
+ my $self = shift;
+ my $old = $self->authority;
+ if (@_) {
+ my $new = $old;
+ $new =~ s/:\d*$//;
+ my $port = shift;
+ $new .= ":$port" if defined $port;
+ $self->authority($new);
+ }
+ return $1 if defined($old) && $old =~ /:(\d*)$/;
+ return;
+}
+
+sub port
+{
+ my $self = shift;
+ my $port = $self->_port(@_);
+ $port = $self->default_port if !defined($port) || $port eq "";
+ $port;
+}
+
+sub host_port
+{
+ my $self = shift;
+ my $old = $self->authority;
+ $self->host(shift) if @_;
+ return undef unless defined $old;
+ $old =~ s/.*@//; # zap userinfo
+ $old =~ s/:$//; # empty port should be treated the same a no port
+ $old .= ":" . $self->port unless $old =~ /:\d+$/;
+ $old;
+}
+
+
+sub default_port { undef }
+
+sub canonical
+{
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+ my $host = $other->host || "";
+ my $port = $other->_port;
+ my $uc_host = $host =~ /[A-Z]/;
+ my $def_port = defined($port) && ($port eq "" ||
+ $port == $self->default_port);
+ if ($uc_host || $def_port) {
+ $other = $other->clone if $other == $self;
+ $other->host(lc $host) if $uc_host;
+ $other->port(undef) if $def_port;
+ }
+ $other;
+}
+
+1;