Using Scalar::Util::reftype instead of just ref(), but mindful this t…

…ime about definedness to avoid warnings Added tests for array objects Ensuring array objects do not stringifies before using them as array Created a function to check if value is an array with no stringification Added tests as requested for stringifyable arrays
libwww-perl · Mar 22, 2024 · 85c5a5c · 85c5a5c
1 parent d586568
commit 85c5a5c
Show file tree

Hide file tree

Showing 5 changed files with 122 additions and 8 deletions.
diff --git a/Changes b/Changes
@@ -1,6 +1,8 @@
 Revision history for URI
 
 {{$NEXT}}
+    - Using Scalar::Util::reftype instead of just ref(), but mindful this time
+      about definedness to avoid warnings (GH#140) (Jacques Deguest)
 
 5.27      2024-02-09 15:01:24Z
     - Add missing NAME section to POD of URI::geo (GH#142) (gregor herrmann)

diff --git a/lib/URI/_query.pm b/lib/URI/_query.pm
@@ -5,6 +5,7 @@ use warnings;
 
 use URI ();
 use URI::Escape qw(uri_unescape);
+use Scalar::Util ();
 
 our $VERSION = '5.28';
 
@@ -34,7 +35,7 @@ sub query_form {
         # Try to set query string
         my $delim;
         my $r = $_[0];
-        if (ref($r) eq "ARRAY") {
+        if (_is_array($r)) {
             $delim = $_[1];
             @_ = @$r;
         }
@@ -49,7 +50,7 @@ sub query_form {
             $key = '' unless defined $key;
 	    $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
 	    $key =~ s/ /+/g;
-	    $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
+	    $vals = [_is_array($vals) ? @$vals : $vals];
             for my $val (@$vals) {
                 if (defined $val) {
                     $val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
@@ -86,7 +87,7 @@ sub query_keywords
     if (@_) {
         # Try to set query string
 	my @copy = @_;
-	@copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY";
+	@copy = @{$copy[0]} if @copy == 1 && _is_array($copy[0]);
 	for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; }
 	$self->query(@copy ? join('+', @copy) : undef);
     }
@@ -114,7 +115,7 @@ sub query_param {
     if (@_) {
         my @new = @old;
         my @new_i = @i;
-        my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
+        my @vals = map { _is_array($_) ? @$_ : $_ } @_;
 
         while (@new_i > @vals) {
             splice @new, pop @new_i, 2;
@@ -139,7 +140,7 @@ sub query_param {
 sub query_param_append {
     my $self = shift;
     my $key = shift;
-    my @vals = map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_;
+    my @vals = map { _is_array($_) ? @$_ : $_ } @_;
     $self->query_form($self->query_form, $key => \@vals);  # XXX
     return;
 }
@@ -168,7 +169,7 @@ sub query_form_hash {
     while (my($k, $v) = splice(@old, 0, 2)) {
         if (exists $hash{$k}) {
             for ($hash{$k}) {
-                $_ = [$_] unless ref($_) eq "ARRAY";
+                $_ = [$_] unless _is_array($_);
                 push(@$_, $v);
             }
         }
@@ -179,4 +180,15 @@ sub query_form_hash {
     return \%hash;
 }
 
+sub _is_array {
+    return(
+        defined($_[0]) &&
+        ( Scalar::Util::reftype($_[0]) || '' ) eq "ARRAY" && 
+        !(
+            Scalar::Util::blessed( $_[0] ) && 
+            overload::Method( $_[0], '""' )
+        )
+    );
+}
+
 1;
diff --git a/t/old-base.t b/t/old-base.t
@@ -348,6 +348,19 @@ sub parts_test {
     $url->query_form(a => ['foo', 'bar'], b => 'foo', c => ['bar', 'foo']);
     is($url->as_string, 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo', ref($url) . '->as_string');
 
+    # Same, but using array object
+    {
+        package
+            Foo::Bar::Array;
+        sub new
+        {
+            my $this = shift( @_ );
+            return( bless( ( @_ == 1 && ref( $_[0] || '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) || $this ) ) );
+        }
+    }
+    $url->query_form(a => Foo::Bar::Array->new(['foo', 'bar']), b => 'foo', c => Foo::Bar::Array->new(['bar', 'foo']));
+    is($url->as_string, 'http://web?a=foo&a=bar&b=foo&c=bar&c=foo', ref($url) . '->as_string');
+
     subtest 'netloc_test' => \&netloc_test;
     subtest 'port_test' => \&port_test;
 

diff --git a/t/query-param.t b/t/query-param.t
@@ -1,7 +1,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => 19;
+use Test::More tests => 20;
 
 use URI ();
 use URI::QueryParam;
@@ -68,4 +68,19 @@ $u->query_param('b' => []);
 
 ok ! $u->query;
 
+# Same, but using array object
+{
+    package
+        Foo::Bar::Array;
+    sub new
+    {
+        my $this = shift( @_ );
+        return( bless( ( @_ == 1 && ref( $_[0] || '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) || $this ) ) );
+    }
+}
+$u->query_param('a' => Foo::Bar::Array->new);
+$u->query_param('b' => Foo::Bar::Array->new);
+
+ok ! $u->query;
+
 is $u->as_string, 'http://www.sol.no';
diff --git a/t/query.t b/t/query.t
@@ -1,12 +1,36 @@
 use strict;
 use warnings;
 
-use Test::More tests => 26;
+use Test::More tests => 37;
 
 use URI ();
 my $u = URI->new("", "http");
 my @q;
 
+# For tests using array object
+{
+    package
+        Foo::Bar::Array;
+    sub new
+    {
+        my $this = shift( @_ );
+        return( bless( ( @_ == 1 && ref( $_[0] || '' ) eq 'ARRAY' ) ? shift( @_ ) : [@_] => ( ref( $this ) || $this ) ) );
+    }
+
+    package
+        Foo::Bar::Stringy;
+    push( @Foo::Bar::Stringy::ISA, 'Foo::Bar::Array' );
+    use overload (
+        '""' => '_as_string',
+    );
+    sub _as_string
+    {
+        my $self = shift;
+        local $" = '_hello_';
+        return( "@$self" );
+    }
+}
+
 $u->query_form(a => 3, b => 4);
 is $u, "?a=3&b=4";
 
@@ -40,24 +64,56 @@ is $u, "?%20+?=%23";
 $u->query_keywords([qw(a b)]);
 is $u, "?a+b";
 
+# Same, but using array object
+$u->query_keywords(Foo::Bar::Array->new([qw(a b)]));
+is $u, "?a+b";
+
+# Same, but using a stringifyable array object
+$u->query_keywords(Foo::Bar::Stringy->new([qw(a b)]));
+is $u, "?a_hello_b";
+
 $u->query_keywords([]);
 is $u, "";
 
+# Same, but using array object
+$u->query_keywords(Foo::Bar::Array->new([]));
+is $u, "";
+
+# Same, but using a stringifyable array object
+$u->query_keywords(Foo::Bar::Stringy->new([]));
+is $u, "?";
+
 $u->query_form({ a => 1, b => 2 });
 ok $u eq "?a=1&b=2" || $u eq "?b=2&a=1";
 
 $u->query_form([ a => 1, b => 2 ]);
 is $u, "?a=1&b=2";
 
+# Same, but using array object
+$u->query_form(Foo::Bar::Array->new([ a => 1, b => 2 ]));
+is $u, "?a=1&b=2";
+
 $u->query_form({});
 is $u, "";
 
 $u->query_form([a => [1..4]]);
 is $u, "?a=1&a=2&a=3&a=4";
 
+# Same, but using array object
+$u->query_form(Foo::Bar::Array->new([a => [1..4]]));
+is $u, "?a=1&a=2&a=3&a=4";
+
 $u->query_form([]);
 is $u, "";
 
+# Same, but using array object
+$u->query_form(Foo::Bar::Array->new([]));
+is $u, "";
+
+# Same, but using a strngifyable array object
+$u->query_form(Foo::Bar::Stringy->new([]));
+is $u, "";
+
 $u->query_form(a => { foo => 1 });
 ok "$u" =~ /^\?a=HASH\(/;
 
@@ -73,13 +129,29 @@ is $u, "?a=1&c=2";
 $u->query_form([a => 1, b => 2], ';');
 is $u, "?a=1;b=2";
 
+# Same, but using array object
+$u->query_form(Foo::Bar::Array->new([a => 1, b => 2]), ';');
+is $u, "?a=1;b=2";
+
+# Same, but using a stringifyable array object
+$u->query_form("c" => Foo::Bar::Stringy->new([a => 1, b => 2]), "d" => "e", ';');
+is $u, "?c=a_hello_1_hello_b_hello_2;d=e";
+
 $u->query_form([]);
 {
     local $URI::DEFAULT_QUERY_FORM_DELIMITER = ';';
     $u->query_form(a => 1, b => 2);
 }
 is $u, "?a=1;b=2";
 
+# Same, but using array object
+$u->query_form(Foo::Bar::Array->new([]));
+{
+    local $URI::DEFAULT_QUERY_FORM_DELIMITER = ';';
+    $u->query_form(a => 1, b => 2);
+}
+is $u, "?a=1;b=2";
+
 $u->query('a&b=2');
 @q = $u->query_form;
 is join(":", map { defined($_) ? $_ : '' } @q), "a::b:2";