fix userinfo in case of some special characters

add some UT for this case
libwww-perl · Aug 17, 2024 · 631eb5f · 631eb5f
1 parent 6c91e5f
commit 631eb5f
Show file tree

Hide file tree

Showing 3 changed files with 66 additions and 12 deletions.
diff --git a/lib/URI.pm b/lib/URI.pm
@@ -123,7 +123,7 @@ sub _fix_uric_escape_for_host_part {
     return;
   }
 
-  if ($_[0] =~ m{^((?:$URI::scheme_re:)?)//([^/?\#]+)(.*)$}os) {
+  if ($_[0] =~ m{^((?:$URI::scheme_re:)?)//((.*:.*@)?[^/?\#]+)(.*)$}os) {
     my $orig          = $2;
     my ($user, $host) = $orig =~ /^(.*@)?([^@]*)$/;
     $user  ||= '';

diff --git a/lib/URI/_server.pm b/lib/URI/_server.pm
@@ -5,19 +5,25 @@ use warnings;
 
 use parent 'URI::_generic';
 
-use URI::Escape qw(uri_unescape);
+use URI::Escape qw(uri_unescape uri_escape);
 
 our $VERSION = '5.29';
 
 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";
-	}
+    if ($str =~ m,^((?:$URI::scheme_re:)?)//(.*:.*@)?([^/?\#]*)(.*)$,os) {
+        my $scheme = $1;
+        my $ui = $2 || '';
+        my $host = $3;
+        my $rest = $4;
+        my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+        if ($ui) {
+            # escape /?# symbols as they are used
+            # in subsequent regex for path parsing
+            $ui = uri_escape($ui, '/?#');
+        }
+        _host_escape($host);
+        $str = "$scheme//$ui$host$port$rest";
     }
     return $class->SUPER::_uric_escape($str);
 }
@@ -26,8 +32,8 @@ sub _host_escape {
   return if  URI::HAS_RESERVED_SQUARE_BRACKETS  and  $_[0] !~ /[^$URI::uric]/;
   return if !URI::HAS_RESERVED_SQUARE_BRACKETS  and  $_[0] !~ /[^$URI::uric4host]/;
     eval {
-	require URI::_idna;
-	$_[0] = URI::_idna::encode($_[0]);
+        require URI::_idna;
+        $_[0] = URI::_idna::encode($_[0]);
     };
     return 0 if $@;
     return 1;

diff --git a/t/http.t b/t/http.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 16;
+use Test::More tests => 76;
 
 use URI ();
 
@@ -48,3 +48,51 @@ $u = URI->new("http://%65%78%61%6d%70%6c%65%2e%63%6f%6d/%70%75%62/%61/%32%30%30%
 is($u->canonical, "http://example.com/pub/a/2001/08/27/bjornstad.html");
 
 ok($u->has_recognized_scheme);
+
+my $username = 'u1!"#$%&\'()*+,-./;<=>?@[\]^_`{|}~';
+my $exp_username = 'u1!%22%23$%&\'()*+,-.%2F;%3C=%3E%3F@%5B%5C%5D%5E_%60%7B%7C%7D~';
+my $password = 'p1!"#$%&\'()*+,-./;<=>?@[\]^_`{|}~';
+my $exp_password = 'p1!%22%23$%&\'()*+,-.%2F;%3C=%3E%3F@%5B%5C%5D%5E_%60%7B%7C%7D~';
+my $path = 'path/to/page';
+my $query = 'a=b&c=d';
+my %host = (
+    '[::1]' => {
+        host => '::1',
+        port => 80,
+    },
+    '[::1]:8080' => {
+        host => '::1',
+        port => 8080,
+    },
+    '127.0.0.1' => {
+        host => '127.0.0.1',
+        port => 80,
+    },
+    '127.0.0.1:8080' => {
+        host => '127.0.0.1',
+        port => 8080,
+    },
+    'localhost' => {
+        host => 'localhost',
+        port => 80,
+    },
+    'localhost:8080' => {
+        host => 'localhost',
+        port => 8080,
+    },
+);
+
+foreach my $host (keys %host) {
+    my $uri = URI->new("http://${username}:${password}\@${host}/${path}?${query}");
+    is($uri->scheme, 'http');
+    is($uri->userinfo, "${exp_username}:${exp_password}");
+    is($uri->host, $host{$host}->{host});
+    is($uri->port, $host{$host}->{port});
+    is($uri->path, "/${path}");
+    is($uri->query, $query);
+    is($uri->authority, "${exp_username}:${exp_password}\@${host}");
+    is($uri->as_string, "http://${exp_username}:${exp_password}\@${host}/${path}?${query}");
+    is($uri->as_iri, "http://${exp_username}:${exp_password}\@${host}/${path}?${query}");
+    is($uri->canonical, "http://${exp_username}:${exp_password}\@${host}/${path}?${query}");
+}
+