In perl.git, the branch smartmatch has been updated <http://perl5.git.perl.org/perl.git/commitdiff/61a621c635b84b53e4eb7d27f7e28c7cd3bdf7e6?hp=168ff818262576c8ec771f99cf50b7095a83e10c>
- Log ----------------------------------------------------------------- commit 61a621c635b84b53e4eb7d27f7e28c7cd3bdf7e6 Author: Rafael Garcia-Suarez <[email protected]> Date: Wed Mar 18 20:20:17 2009 +0100 Smart match when a hash is on the RHS This implement the new semantics of C<~~ HASH> smart matching. This also reveals that overloading actually does not work at all. Add also tests for C<undef ~~ %hash>. M pp_ctl.c M t/op/smartmatch.t commit 2e0e16c9a7efc2d1fccff9f29d125f34121cb65d Author: Rafael Garcia-Suarez <[email protected]> Date: Wed Mar 18 20:12:47 2009 +0100 Reverse the order of operands for several "~~ hash" tests This way the hash is on the right. Some of those tests will need to become symmetrical later. M t/op/smartmatch.t commit 0cfbf1eabaa9be38a1db953e3ec905f70a1605cd Author: Rafael Garcia-Suarez <[email protected]> Date: Wed Mar 18 19:29:34 2009 +0100 Remove obsolete or redundant tests M t/op/smartmatch.t ----------------------------------------------------------------------- Summary of changes: pp_ctl.c | 22 ++++++++++++----- t/op/smartmatch.t | 66 +++++++++++++++++++++++----------------------------- 2 files changed, 44 insertions(+), 44 deletions(-) diff --git a/pp_ctl.c b/pp_ctl.c index 1b4bbf5..3977953 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -4161,15 +4161,19 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETURN; } } - else if (SM_REF(PVHV)) { - if (SM_OTHER_REF(PVHV)) { + else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) { + if (!SvOK(d)) { + RETPUSHNO; + } + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) { /* Check that the key-sets are identical */ HE *he; - HV *other_hv = MUTABLE_HV(SvRV(Other)); + HV *other_hv = MUTABLE_HV(SvRV(d)); bool tied = FALSE; bool other_tied = FALSE; U32 this_key_count = 0, other_key_count = 0; + This = SvRV(e); /* Tied hashes don't know how many keys they have. */ if (SvTIED_mg(This, PERL_MAGIC_tied)) { @@ -4215,10 +4219,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) else RETPUSHYES; } - else if (SM_OTHER_REF(PVAV)) { - AV * const other_av = MUTABLE_AV(SvRV(Other)); + else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV * const other_av = MUTABLE_AV(SvRV(d)); const I32 other_len = av_len(other_av) + 1; I32 i; + This = SvRV(e); for (i = 0; i < other_len; ++i) { SV ** const svp = av_fetch(other_av, i, FALSE); @@ -4233,9 +4238,12 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } RETPUSHNO; } - else if (SM_OTHER_REGEX) { + else if (SvROK(d) + && (SvTYPE(SvRV(d)) == SVt_REGEXP) + && (other_regex = (REGEXP*) SvRV(d))) { PMOP * const matcher = make_matcher(other_regex); HE *he; + This = SvRV(e); (void) hv_iterinit(MUTABLE_HV(This)); while ( (he = hv_iternext(MUTABLE_HV(This))) ) { @@ -4249,7 +4257,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; } else { - if (hv_exists_ent(MUTABLE_HV(This), Other, 0)) + if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0)) RETPUSHYES; else RETPUSHNO; diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t index 5fd3587..a8b387b 100644 --- a/t/op/smartmatch.t +++ b/t/op/smartmatch.t @@ -86,9 +86,9 @@ sub bar {42} sub gorch {42} sub fatal {die "fatal sub\n"} +# to test constant folding sub FALSE() { 0 } sub TRUE() { 1 } -sub TWO() { 1 } # Prefix character : # - expected to match @@ -142,6 +142,7 @@ __DATA__ $ov_obj $ov_obj =@ $ov_obj \&fatal =! $ov_obj \&FALSE += $ov_obj \&TRUE =! $ov_obj \&foo = $ov_obj \&bar = $ov_obj sub { shift ~~ "key" } @@ -152,21 +153,22 @@ __DATA__ = $ov_obj {"key" => 1} = $ov_obj {"key" => 1, bar => 2} TODO =! $ov_obj {"foo" => 1} -= $ov_obj @keyandmore += $ov_obj @keyandmore TODO =! $ov_obj @fooormore -= $ov_obj ["key" => 1] += $ov_obj ["key" => 1] TODO =! $ov_obj ["foo" => 1] -= $ov_obj /key/ += $ov_obj /key/ TODO =! $ov_obj /foo/ -= $ov_obj qr/Key/i += $ov_obj qr/Key/i TODO =! $ov_obj qr/foo/ -= $ov_obj "key" += $ov_obj "key" TODO =! $ov_obj "foo" =! $ov_obj FALSE +=! $ov_obj TRUE # regular object =@ $obj $ov_obj -=@ $obj $obj +@ $obj $obj =@ $obj \&fatal =@ $obj \&FALSE =@ $obj \&foo @@ -227,19 +229,6 @@ __DATA__ ! [] \&fatal ! +{} \&fatal -# - null-prototyped subs -! undef \&FALSE - undef \&TRUE -! 0 \&FALSE - 0 \&TRUE -! 1 \&FALSE - 1 \&TRUE -! \&FALSE \&foo - -# - non-null-prototyped subs - bar gorch -@ fatal bar - # HASH ref against: # - another hash ref {} {} @@ -254,24 +243,27 @@ __DATA__ \%tied_hash \%tied_hash # - an array ref - \%:: [keys %main::] -! \%:: [] - {"" => 1} [undef] - { foo => 1 } ["foo"] - { foo => 1 } ["foo", "bar"] - \%hash ["foo", "bar"] - \%hash ["foo"] -! \%hash ["quux"] - \%hash [qw(foo quux)] + [keys %main::] \%:: +! [] \%:: + [undef] {"" => 1} + ["foo"] { foo => 1 } + ["foo", "bar"] { foo => 1 } + ["foo", "bar"] \%hash + ["foo"] \%hash +! ["quux"] \%hash + [qw(foo quux)] \%hash # - a regex - {foo => 1} qr/^(fo[ox])$/ -! +{0..99} qr/[13579]$/ + qr/^(fo[ox])$/ {foo => 1} +! qr/[13579]$/ +{0..99} # - a string - +{foo => 1, bar => 2} "foo" -! +{foo => 1, bar => 2} "baz" + "foo" +{foo => 1, bar => 2} +! "baz" +{foo => 1, bar => 2} +# - undef +! undef %hash +! undef +{"" => "empty key"} # ARRAY ref against: # - another array ref @@ -327,10 +319,10 @@ __DATA__ @nums [1..10] ! @nums [0..9] - %hash "foo" - %hash /bar/ - %hash [qw(bar)] -! %hash [qw(a b c)] + "foo" %hash + /bar/ %hash + [qw(bar)] %hash +! [qw(a b c)] %hash %hash %hash %hash +{%hash} %hash \%hash -- Perl5 Master Repository
