From 7ac5715b7e1d379bf1c97420a56388ecdfacd30f Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Mon, 18 Apr 2011 17:44:01 -0700 Subject: [PATCH] Make keys/value/each $scalar accept only unblessed refs See ticket #80626. --- op.c | 9 +++- pod/perldiag.pod | 6 +-- pp.c | 56 +++++------------------ t/op/smartkve.t | 136 +++++++++++++++++++++++++++++++++++++------------------ 4 files changed, 112 insertions(+), 95 deletions(-) diff --git a/op.c b/op.c index 41bb59f..f22f888 100644 --- a/op.c +++ b/op.c @@ -9171,11 +9171,16 @@ Perl_ck_each(pTHX_ OP *o) CHANGE_TYPE(o, array_type); break; case OP_CONST: - if (kid->op_private == OPpCONST_BARE) - /* we let ck_fun treat as hash */ + if (kid->op_private == OPpCONST_BARE + || !SvROK(cSVOPx_sv(kid)) + || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV + && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV ) + ) + /* we let ck_fun handle it */ break; default: CHANGE_TYPE(o, ref_type); + scalar(kid); } } /* if treating as a reference, defer additional checks to runtime */ diff --git a/pod/perldiag.pod b/pod/perldiag.pod index cc19311..56e8408 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -4660,10 +4660,10 @@ certain type. Arrays must be @NAME or C<@{EXPR}>. Hashes must be %NAME or C<%{EXPR}>. No implicit dereferencing is allowed--use the {EXPR} forms as an explicit dereference. See L. -=item Type of argument to %s must be hashref or arrayref +=item Type of argument to %s must be unblessed hashref or arrayref -(F) You called C, C or C with an argument that was -expected to be a reference to a hash or a reference to an array. +(F) You called C, C or C with a scalar argument that +was not a reference to an unblessed hash or array. =item umask not implemented diff --git a/pp.c b/pp.c index 058a068..5b32daf 100644 --- a/pp.c +++ b/pp.c @@ -4836,51 +4836,17 @@ PP(pp_rkeys) dSP; dPOPss; - if (!SvOK(sv)) - RETURN; - - if (SvROK(sv)) { - SvGETMAGIC(sv); - if (SvAMAGIC(sv)) { - /* N.B.: AMG macros return sv if no overloading is found */ - SV *maybe_hv = AMG_CALLunary(sv, to_hv_amg); - SV *maybe_av = AMG_CALLunary(sv, to_av_amg); - if ( maybe_hv != sv && maybe_av != sv ) { - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", - Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}", - PL_op_desc[PL_op->op_type] - ) - ); - sv = maybe_hv; - } - else if ( maybe_av != sv ) { - if ( SvTYPE(SvRV(sv)) == SVt_PVHV ) { - /* @{} overload, but underlying reftype is HV */ - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", - Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as @{}", - PL_op_desc[PL_op->op_type] - ) - ); - } - sv = maybe_av; - } - else if ( maybe_hv != sv ) { - if ( SvTYPE(SvRV(sv)) == SVt_PVAV ) { - /* %{} overload, but underlying reftype is AV */ - Perl_ck_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "%s", - Perl_form(aTHX_ "Ambiguous overloaded argument to %s resolved as %%{}", - PL_op_desc[PL_op->op_type] - ) - ); - } - sv = maybe_hv; - } - } - sv = SvRV(sv); - } - - if ( SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV ) { - DIE(aTHX_ "Type of argument to %s must be hashref or arrayref", + SvGETMAGIC(sv); + + if ( + !SvROK(sv) + || (sv = SvRV(sv), + (SvTYPE(sv) != SVt_PVHV && SvTYPE(sv) != SVt_PVAV) + || SvOBJECT(sv) + ) + ) { + DIE(aTHX_ + "Type of argument to %s must be unblessed hashref or arrayref", PL_op_desc[PL_op->op_type] ); } diff --git a/t/op/smartkve.t b/t/op/smartkve.t index 4cb19f5..7c57e7b 100644 --- a/t/op/smartkve.t +++ b/t/op/smartkve.t @@ -8,7 +8,7 @@ BEGIN { use strict; use warnings; no warnings 'deprecated'; -use vars qw($data $array $values $hash); +use vars qw($data $array $values $hash $errpat); plan 'no_plan'; @@ -124,26 +124,39 @@ is(j(keys array_sub) ,$a_expect, 'List: keys array_sub'); is(j(keys array_sub()) ,$a_expect, 'List: keys array_sub()'); is(j(keys $obj->array) ,$a_expect, 'List: keys $obj->array'); -# Keys -- undef - -undef $empty; -is(j(keys undef), '', 'Undef: keys undef is empty list'); -is(j(keys $empty), '', 'Undef: keys $empty is empty list'); -is($empty, undef, 'Undef: $empty is not vivified'); - # Keys -- vivification -is(j(keys $empty->{hash}), '', 'Vivify: keys $empty->{hash}'); -ok(defined $empty , 'Vivify: $empty is HASHREF'); +undef $empty; +eval { keys $empty->{hash} }; +ok(defined $empty, + 'Vivify: $empty (after keys $empty->{hash}) is HASHREF'); ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); # Keys -- errors +$errpat = qr/ + (?-x:Type of argument to keys on reference must be unblessed hashref or) + (?-x: arrayref) +/x; + +eval "keys undef"; +ok($@ =~ $errpat, + 'Errors: keys undef throws error' +); + +undef $empty; +eval q"keys $empty"; +ok($@ =~ $errpat, + 'Errors: keys $undef throws error' +); + +is($empty, undef, 'keys $undef does not vivify $undef'); + eval "keys 3"; -ok($@ =~ qr/Type of argument to keys on reference must be hashref or arrayref/, +ok($@ =~ qr/Type of arg 1 to keys must be hash/, 'Errors: keys CONSTANT throws error' ); eval "keys qr/foo/"; -ok($@ =~ qr/Type of argument to keys on reference must be hashref or arrayref/, +ok($@ =~ $errpat, 'Errors: keys qr/foo/ throws error' ); @@ -206,26 +219,39 @@ is(j(values array_sub) ,$a_expect, 'List: values array_sub'); is(j(values array_sub()) ,$a_expect, 'List: values array_sub()'); is(j(values $obj->array) ,$a_expect, 'List: values $obj->array'); -# Values -- undef - -undef $empty; -is(j(values undef), '', 'Undef: values undef is empty list'); -is(j(values $empty), '', 'Undef: values $empty is empty list'); -is($empty, undef, 'Undef: $empty is not vivified'); - # Values -- vivification -is(j(values $empty->{hash}), '', 'Vivify: values $empty->{hash}'); -ok(defined $empty , 'Vivify: $empty is HASHREF'); +undef $empty; +eval { values $empty->{hash} }; +ok(defined $empty, + 'Vivify: $empty (after values $empty->{hash}) is HASHREF'); ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); # Values -- errors +$errpat = qr/ + (?-x:Type of argument to values on reference must be unblessed hashref or) + (?-x: arrayref) +/x; + +eval "values undef"; +ok($@ =~ $errpat, + 'Errors: values undef throws error' +); + +undef $empty; +eval q"values $empty"; +ok($@ =~ $errpat, + 'Errors: values $undef throws error' +); + +is($empty, undef, 'values $undef does not vivify $undef'); + eval "values 3"; -ok($@ =~ qr/Type of argument to values on reference must be hashref or arrayref/, +ok($@ =~ qr/Type of arg 1 to values must be hash/, 'Errors: values CONSTANT throws error' ); eval "values qr/foo/"; -ok($@ =~ qr/Type of argument to values on reference must be hashref or arrayref/, +ok($@ =~ $errpat, 'Errors: values qr/foo/ throws error' ); @@ -302,26 +328,39 @@ keys $obj->array; @tmp=@tmp2=(); while(($k,$v) = each array_sub()){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys array_sub(), values array_sub()), 'List: each array_sub()'); @tmp=@tmp2=(); while(($k,$v) = each $obj->array){push @tmp,$k; push @tmp2,$v}; is(j(@tmp,@tmp2),j(keys $obj->array, values $obj->array), 'List: each $obj->array'); -# Each -- undef +# Each -- vivification +undef $empty; +eval { each $empty->{hash} }; +ok(defined $empty, + 'Vivify: $empty (after each $empty->{hash}) is HASHREF'); +ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); + +# Each -- errors +$errpat = qr/ + (?-x:Type of argument to each on reference must be unblessed hashref or) + (?-x: arrayref) +/x; + +eval "each undef"; +ok($@ =~ $errpat, + 'Errors: each undef throws error' +); undef $empty; -is(j(@{[each undef]}), '', 'Undef: each undef is empty list'); -is(j(@{[each $empty]}), '', 'Undef: each $empty is empty list'); -is($empty, undef, 'Undef: $empty is not vivified'); +eval q"each $empty"; +ok($@ =~ $errpat, + 'Errors: each $undef throws error' +); -# Values -- vivification -is(j(@{[each $empty->{hash}]}), '', 'Vivify: each $empty->{hash} is empty list'); -ok(defined $empty , 'Vivify: $empty is HASHREF'); -ok(!defined $empty->{hash} , 'Vivify: $empty->{hash} is undef'); +is($empty, undef, 'each $undef does not vivify $undef'); -# Values -- errors eval "each 3"; -ok($@ =~ qr/Type of argument to each on reference must be hashref or arrayref/, +ok($@ =~ qr/Type of arg 1 to each must be hash/, 'Errors: each CONSTANT throws error' ); eval "each qr/foo/"; -ok($@ =~ qr/Type of argument to each on reference must be hashref or arrayref/, +ok($@ =~ $errpat, 'Errors: each qr/foo/ throws error' ); @@ -337,25 +376,32 @@ my $over_b = Foo::Overload::Both->new; my $over_h_a = Foo::Overload::HashOnArray->new; my $over_a_h = Foo::Overload::ArrayOnHash->new; -my $re_warn_array = qr/Ambiguous overloaded argument to keys on reference resolved as \@\{\}/; -my $re_warn_hash = qr/Ambiguous overloaded argument to keys on reference resolved as \%\{\}/; - { my $warn = ''; local $SIG{__WARN__} = sub { $warn = shift }; - is(j(keys $over_a), j(keys @$array), "Overload: array dereference"); + $errpat = qr/ + (?-x:Type of argument to keys on reference must be unblessed hashref or) + (?-x: arrayref) + /x; + + eval { keys $over_a }; + like($@, $errpat, "Overload: array dereference"); is($warn, '', "no warning issued"); $warn = ''; - is(j(keys $over_h), j(keys %$hash), "Overload: hash dereference"); + eval { keys $over_h }; + like($@, $errpat, "Overload: hash dereference"); is($warn, '', "no warning issued"); $warn = ''; - is(j(keys $over_b), j(keys %$hash), "Overload: ambiguous dereference (both) resolves to hash"); - like($warn, $re_warn_hash, "warning correct"); $warn = ''; + eval { keys $over_b }; + like($@, $errpat, "Overload: ambiguous dereference (both)"); + is($warn, '', "no warning issued"); $warn = ''; - is(j(keys $over_h_a), j(keys %$hash), "Overload: ambiguous dereference resolves to hash"); - like($warn, $re_warn_hash, "warning correct"); $warn = ''; + eval { keys $over_h_a }; + like($@, $errpat, "Overload: ambiguous dereference"); + is($warn, '', "no warning issued"); $warn = ''; - is(j(keys $over_a_h), j(keys @$array), "Overload: ambiguous dereference resolves to array"); - like($warn, $re_warn_array, "warning correct"); $warn = ''; + eval { keys $over_a_h }; + like($@, $errpat, "Overload: ambiguous dereference"); + is($warn, '', "no warning issued"); $warn = ''; } -- 2.7.4