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