Merge branch 'smartmatch' into blead
authorRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Wed, 13 May 2009 13:05:49 +0000 (15:05 +0200)
committerDavid Mitchell <davem@iabyn.com>
Tue, 9 Jun 2009 16:26:19 +0000 (17:26 +0100)
cherry-picked from commit 56d86adf5b, which is a merge, so all the
individual commits from the smartmatch branch have been sucked in as a
single commit. Note that this won't yet compile, as the SVt_REGEXP stuff
needs removing for 5.10.x.

lib/overload.pm
op.c
pod/perlsyn.pod
pod/perltodo.pod
pp_ctl.c
t/lib/warnings/9uninit
t/op/smartmatch.t
t/op/switch.t

index 8bef2d4..f1df27f 100644 (file)
@@ -133,6 +133,7 @@ sub mycan {                         # Real can would leave stubs.
         conversion       => 'bool "" 0+',
         iterators        => '<>',
         dereferencing    => '${} @{} %{} &{} *{}',
+        matching         => '~~',
         special          => 'nomethod fallback =');
 
 use warnings::register;
@@ -420,6 +421,11 @@ I<globbing> syntax C<E<lt>${var}E<gt>>.
 B<BUGS> Even in list context, the iterator is currently called only
 once and with scalar context.
 
+=item * I<Matching>
+
+The key C<"~~"> allows you to override the smart matching used by
+the switch construct. See L<feature>.
+
 =item * I<Dereferencing>
 
     '${}', '@{}', '%{}', '&{}', '*{}'.
@@ -436,7 +442,7 @@ The dereference operators must be specified explicitly they will not be passed t
 
 =item * I<Special>
 
-    "nomethod", "fallback", "=", "~~",
+    "nomethod", "fallback", "=".
 
 see L<SPECIAL SYMBOLS FOR C<use overload>>.
 
@@ -460,6 +466,7 @@ A computer-readable form of the above table is available in the hash
  conversion      => 'bool "" 0+',
  iterators       => '<>',
  dereferencing   => '${} @{} %{} &{} *{}',
+ matching        => '~~',
  special         => 'nomethod fallback ='
 
 =head2 Inheritance and overloading
@@ -556,11 +563,6 @@ C<"nomethod"> value, and if this is missing, raises an exception.
 B<Note.> C<"fallback"> inheritance via @ISA is not carved in stone
 yet, see L<"Inheritance and overloading">.
 
-=head2 Smart Match
-
-The key C<"~~"> allows you to override the smart matching used by
-the switch construct. See L<feature>.
-
 =head2 Copy Constructor
 
 The value for C<"="> is a reference to a function with three
diff --git a/op.c b/op.c
index 246c843..8b9ee49 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5139,6 +5139,7 @@ S_looks_like_bool(pTHX_ const OP *o)
 
     switch(o->op_type) {
        case OP_OR:
+       case OP_DOR:
            return looks_like_bool(cLOGOPo->op_first);
 
        case OP_AND:
@@ -5154,7 +5155,6 @@ S_looks_like_bool(pTHX_ const OP *o)
        case OP_ENTERSUB:
 
        case OP_NOT:    case OP_XOR:
-       /* Note that OP_DOR is not here */
 
        case OP_EQ:     case OP_NE:     case OP_LT:
        case OP_GT:     case OP_LE:     case OP_GE:
@@ -5179,6 +5179,8 @@ S_looks_like_bool(pTHX_ const OP *o)
        case OP_DEFINED: case OP_EXISTS:
        case OP_MATCH:   case OP_EOF:
 
+       case OP_FLOP:
+
            return TRUE;
        
        case OP_CONST:
@@ -5187,7 +5189,9 @@ S_looks_like_bool(pTHX_ const OP *o)
            ||  cSVOPo->op_sv == &PL_sv_no)
            
                return TRUE;
-               
+           else
+               return FALSE;
+
        /* FALL THROUGH */
        default:
            return FALSE;
index ec86510..5793408 100644 (file)
@@ -516,24 +516,19 @@ This construct is very flexible and powerful. For example:
        when (undef) {
            say '$foo is undefined';
        }
-       
        when ("foo") {
            say '$foo is the string "foo"';
        }
-       
        when ([1,3,5,7,9]) {
            say '$foo is an odd digit';
            continue; # Fall through
        }
-       
        when ($_ < 100) {
            say '$foo is numerically less than 100';
        }
-       
        when (\&complicated_check) {
-           say 'complicated_check($foo) is true';
+           say 'a complicated check for $foo is true';
        }
-       
        default {
            die q(I don't know what to do with $foo);
        }
@@ -567,7 +562,7 @@ a subroutine or method call
 =item *
 
 a regular expression match, i.e. C</REGEX/> or C<$foo =~ /REGEX/>,
-or a negated regular expression match C<$foo !~ /REGEX/>.
+or a negated regular expression match (C<!/REGEX/> or C<$foo !~ /REGEX/>).
 
 =item *
 
@@ -580,26 +575,36 @@ C<defined(...)>, C<exists(...)>, or C<eof(...)>
 
 =item *
 
-A negated expression C<!(...)> or C<not (...)>, or a logical
+a negated expression C<!(...)> or C<not (...)>, or a logical
 exclusive-or C<(...) xor (...)>.
 
+=item *
+
+a filetest operator, with the exception of C<-s>, C<-M>, C<-A>, and C<-C>,
+that return numerical values, not boolean ones.
+
+=item *
+
+the C<..> and C<...> flip-flop operators.
+
 =back
 
-then the value of EXPR is used directly as a boolean.
+In those cases the value of EXPR is used directly as a boolean.
+
 Furthermore:
 
 =over 4
 
-=item o
+=item *
 
 If EXPR is C<... && ...> or C<... and ...>, the test
 is applied recursively to both arguments. If I<both>
 arguments pass the test, then the argument is treated
 as boolean.
 
-=item o
+=item *
 
-If EXPR is C<... || ...> or C<... or ...>, the test
+If EXPR is C<... || ...>, C<... // ...> or C<... or ...>, the test
 is applied recursively to the first argument.
 
 =back
@@ -659,47 +664,51 @@ variable C<$_>. (You can use C<for my $_ (@array)>.)
 
 =head3 Smart matching in detail
 
-The behaviour of a smart match depends on what type of thing
-its arguments are. It is always commutative, i.e. C<$a ~~ $b>
-behaves the same as C<$b ~~ $a>. The behaviour is determined
-by the following table: the first row that applies, in either
-order, determines the match behaviour.
-
+The behaviour of a smart match depends on what type of thing its arguments
+are. The behaviour is determined by the following table: the first row
+that applies determines the match behaviour (which is thus mostly
+determined by the type of the right operand). Note that the smart match
+implicitly dereferences any non-blessed hash or array ref, so the "Hash"
+and "Array" entries apply in those cases. (For blessed references, the
+"Any" entry apply.)
 
     $a      $b        Type of Match Implied    Matching Code
     ======  =====     =====================    =============
-    (overloading trumps everything)
+    Any     undef     undefined                !defined $a
+
+    Any     Object   invokes ~~ overloading on $object, or dies
 
-    Code[+] Code[+]   referential equality     $a == $b
-    Any     Code[+]   scalar sub truth         $b->($a)
+    Hash    CodeRef   sub truth for each key[1] !grep { !$b->($_) } keys %$a
+    Array   CodeRef   sub truth for each elt[1] !grep { !$b->($_) } @$a
+    Any     CodeRef   scalar sub truth          $b->($a)
 
     Hash    Hash      hash keys identical      [sort keys %$a]~~[sort keys %$b]
-    Hash    Array     hash slice existence     @$b == grep {exists $a->{$_}} @$b
-    Hash    Regex     hash key grep            grep /$b/, keys %$a
-    Hash    Any       hash entry existence     exists $a->{$b}
+    Array   Hash      hash slice existence     grep { exists $b->{$_} } @$a
+    Regex   Hash      hash key grep            grep /$a/, keys %$b
+    undef   Hash      always false (undef can't be a key)
+    Any     Hash      hash entry existence     exists $b->{$a}
+
+    Hash    Array     hash slice existence     grep { exists $a->{$_} } @$b
+    Array   Array     arrays are comparable[2]
+    Regex   Array     array grep               grep /$a/, @$b
+    undef   Array     array contains undef     grep !defined, @$b
+    Any     Array     match against an array element[3]
+                                               grep $a ~~ $_, @$b
 
-    Array   Array     arrays are identical[*]
+    Hash    Regex     hash key grep            grep /$b/, keys %$a
     Array   Regex     array grep               grep /$b/, @$a
-    Array   Num       array contains number    grep $_ == $b, @$a
-    Array   Any       array contains string    grep $_ eq $b, @$a
-
-    Any     undef     undefined                !defined $a
     Any     Regex     pattern match            $a =~ /$b/
-    Code()  Code()    results are equal        $a->() eq $b->()
-    Any     Code()    simple closure truth     $b->() # ignoring $a
-    Num     numish[!] numeric equality         $a == $b
-    Any     Str       string equality          $a eq $b
-    Any     Num       numeric equality         $a == $b
 
+    Any     Num       numeric equality         $a == $b
+    Num     numish[4] numeric equality         $a == $b
     Any     Any       string equality          $a eq $b
 
 
- + - this must be a code reference whose prototype (if present) is not ""
-     (subs with a "" prototype are dealt with by the 'Code()' entry lower down)
- * - that is, each element matches the element of same index in the other
-     array. If a circular reference is found, we fall back to referential
-     equality.
- ! - either a real number, or a string that looks like a number
+ 1 - empty hashes or arrays will match.
+ 2 - that is, each element smart-matches the element of same index in the
+     other array. [3]
+ 3 - If a circular reference is found, we fall back to referential equality.
+ 4 - either a real number, or a string that looks like a number
 
 The "matching code" doesn't represent the I<real> matching code,
 of course: it's just there to explain the intended meaning. Unlike
@@ -709,7 +718,13 @@ C<grep>, the smart match operator will short-circuit whenever it can.
 
 You can change the way that an object is matched by overloading
 the C<~~> operator. This trumps the usual smart match semantics.
-See L<overload>.
+See L<overload>. Since smart matching dispatch is driven by the
+right hand side argument, overloading applies only when the object
+is on the right of C<~~>.
+
+It should be noted that C<~~> will refuse to work on objects that
+don't overload it (in order to avoid relying on the object's
+underlying structure).
 
 =head3 Differences from Perl 6
 
index 65e8d8c..5694482 100644 (file)
@@ -26,55 +26,6 @@ programming languages offer you 1 line of immortality?
 
 =head1 Tasks that only need Perl knowledge
 
-=head2 Smartmatch design issues
-
-In 5.10.0 the smartmatch operator C<~~> isn't working quite "right". But
-before we can fix the implementation, we need to define what "right" is.
-The first problem is that Robin Houston implemented the Perl 6 smart match
-spec as of February 2006, when smart match was axiomatically symmetrical:
-L<http://groups.google.com/group/perl.perl6.language/msg/bf2b486f089ad021>
-
-Since then the Perl 6 target moved, but the Perl 5 implementation did not.
-
-So it would be useful for someone to compare the Perl 6 smartmatch table
-as of February 2006 L<http://svn.perl.org/viewvc/perl6/doc/trunk/design/syn/S03.pod?view=markup&pathrev=7615>
-and the current table L<http://svn.perl.org/viewvc/perl6/doc/trunk/design/syn/S03.pod?revision=14556&view=markup>
-and tabulate the differences in Perl 6. The annotated view of changes is
-L<http://svn.perl.org/viewvc/perl6/doc/trunk/design/syn/S03.pod?view=annotate> and the diff is
-C<svn diff -r7615:14556 http://svn.perl.org/perl6/doc/trunk/design/syn/S03.pod>
--- search for C<=head1 Smart matching>. (In theory F<viewvc> can generate that,
-but in practice when I tried it hung forever, I assume "thinking")
-
-With that done and published, someone (else) can then map any changed Perl 6
-semantics back to Perl 5, based on how the existing semantics map to Perl 5:
-L<http://search.cpan.org/~rgarcia/perl-5.10.0/pod/perlsyn.pod#Smart_matching_in_detail>
-
-
-There are also some questions that need answering:
-
-=over 4
-
-=item *
-
-How do you negate one?  (documentation issue)
-http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2008-01/msg00071.html
-
-=item *
-
-Array behaviors
-http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2007-12/msg00799.html
-
-* Should smart matches be symmetrical? (Perl 6 says no)
-
-* Other differences between Perl 5 and Perl 6 smart match?
-
-=item *
-
-Objects and smart match
-http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2007-12/msg00865.html
-
-=back
-
 =head2 Remove duplication of test setup.
 
 Schwern notes, that there's duplication of code - lots and lots of tests have
index b4f0ade..7afa1d5 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3960,59 +3960,21 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     dVAR;
     dSP;
     
+    bool object_on_left = FALSE;
     SV *e = TOPs;      /* e is for 'expression' */
     SV *d = TOPm1s;    /* d is for 'default', as in PL_defgv */
-    SV *This, *Other;  /* 'This' (and Other to match) to play with C++ */
     MAGIC *mg;
-    REGEXP *this_regex, *other_regex;
-
-#   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
-
-#   define SM_REF(type) ( \
-          (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
-       || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
-
-#   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
-       ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
-           && NOT_EMPTY_PROTO(This) && (Other = e))                    \
-       || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
-           && NOT_EMPTY_PROTO(This) && (Other = d)))
-
-#   define SM_REGEX ( \
-          (SvROK(d) && SvMAGICAL(This = SvRV(d))                       \
-       && (mg = mg_find(This, PERL_MAGIC_qr))                          \
-       && (this_regex = (regexp *)mg->mg_obj)                          \
-       && (Other = e))                                                 \
-    ||                                                                 \
-          (SvROK(e) && SvMAGICAL(This = SvRV(e))                       \
-       && (mg = mg_find(This, PERL_MAGIC_qr))                          \
-       && (this_regex = (regexp *)mg->mg_obj)                          \
-       && (Other = d)) )
-       
-
-#   define SM_OBJECT ( \
-          (sv_isobject(d) && (!SvMAGICAL(This = SvRV(d))               \
-                           || !mg_find(This, PERL_MAGIC_qr)))          \
-    ||                                                                 \
-          (sv_isobject(e) && (!SvMAGICAL(This = SvRV(e))               \
-                           || !mg_find(This, PERL_MAGIC_qr))) )
-
-#   define SM_OTHER_REF(type) \
-       (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
-
-#   define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other))      \
-       && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr))                   \
-       && (other_regex = (regexp *)mg->mg_obj))
-       
 
-#   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
-       sv_2mortal(newSViv(PTR2IV(sv))), 0)
-
-#   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
-       sv_2mortal(newSViv(PTR2IV(sv))), 0)
+    if (SvAMAGIC(e)) {
+       SV * const tmpsv = amagic_call(d, e, smart_amg, 0);
+       if (tmpsv) {
+           SPAGAIN;
+           (void)POPs;
+           SETs(tmpsv);
+           RETURN;
+       }
+    }
 
-    tryAMAGICbinSET(smart, 0);
-    
     SP -= 2;   /* Pop the values */
 
     /* Take care only to invoke mg_get() once for each argument. 
@@ -4028,76 +3990,146 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     if (SvGMAGICAL(e))
        e = sv_mortalcopy(e);
 
-    if (SM_OBJECT) {
-       if (!SvOK(d) || !SvOK(e))
+    /* ~~ undef */
+    if (!SvOK(e)) {
+       if (SvOK(d))
            RETPUSHNO;
        else
-           Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+           RETPUSHYES;
     }
 
-    if (SM_CV_NEP) {
+    if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP))
+       Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
+    if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
+       object_on_left = TRUE;
+
+    /* ~~ sub */
+    if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
        I32 c;
-       
-       if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
-       {
-           if (This == SvRV(Other))
+       if (object_on_left) {
+           goto sm_any_sub; /* Treat objects like scalars */
+       }
+       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+           /* Test sub truth for each key */
+           HE *he;
+           bool andedresults = TRUE;
+           HV *hv = (HV*) SvRV(d);
+           I32 numkeys = hv_iterinit(hv);
+           if (numkeys == 0)
+               RETPUSHYES;
+           while ( (he = hv_iternext(hv)) ) {
+               ENTER;
+               SAVETMPS;
+               PUSHMARK(SP);
+               PUSHs(hv_iterkeysv(he));
+               PUTBACK;
+               c = call_sv(e, G_SCALAR);
+               SPAGAIN;
+               if (c == 0)
+                   andedresults = FALSE;
+               else
+                   andedresults = SvTRUEx(POPs) && andedresults;
+               FREETMPS;
+               LEAVE;
+           }
+           if (andedresults)
                RETPUSHYES;
            else
                RETPUSHNO;
        }
-       
-       ENTER;
-       SAVETMPS;
-       PUSHMARK(SP);
-       PUSHs(Other);
-       PUTBACK;
-       c = call_sv(This, G_SCALAR);
-       SPAGAIN;
-       if (c == 0)
-           PUSHs(&PL_sv_no);
-       else if (SvTEMP(TOPs))
-           SvREFCNT_inc_void(TOPs);
-       FREETMPS;
-       LEAVE;
-       RETURN;
+       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+           /* Test sub truth for each element */
+           I32 i;
+           bool andedresults = TRUE;
+           AV *av = (AV*) SvRV(d);
+           const I32 len = av_len(av);
+           if (len == -1)
+               RETPUSHYES;
+           for (i = 0; i <= len; ++i) {
+               SV * const * const svp = av_fetch(av, i, FALSE);
+               ENTER;
+               SAVETMPS;
+               PUSHMARK(SP);
+               if (svp)
+                   PUSHs(*svp);
+               PUTBACK;
+               c = call_sv(e, G_SCALAR);
+               SPAGAIN;
+               if (c == 0)
+                   andedresults = FALSE;
+               else
+                   andedresults = SvTRUEx(POPs) && andedresults;
+               FREETMPS;
+               LEAVE;
+           }
+           if (andedresults)
+               RETPUSHYES;
+           else
+               RETPUSHNO;
+       }
+       else {
+         sm_any_sub:
+           ENTER;
+           SAVETMPS;
+           PUSHMARK(SP);
+           PUSHs(d);
+           PUTBACK;
+           c = call_sv(e, G_SCALAR);
+           SPAGAIN;
+           if (c == 0)
+               PUSHs(&PL_sv_no);
+           else if (SvTEMP(TOPs))
+               SvREFCNT_inc_void(TOPs);
+           FREETMPS;
+           LEAVE;
+           RETURN;
+       }
     }
-    else if (SM_REF(PVHV)) {
-       if (SM_OTHER_REF(PVHV)) {
+    /* ~~ %hash */
+    else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
+       if (object_on_left) {
+           goto sm_any_hash; /* Treat objects like scalars */
+       }
+       else 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;
+           HV *hv = MUTABLE_HV(SvRV(e));
            
            /* Tied hashes don't know how many keys they have. */
-           if (SvTIED_mg(This, PERL_MAGIC_tied)) {
+           if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
                tied = TRUE;
            }
            else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
                HV * const temp = other_hv;
-               other_hv = MUTABLE_HV(This);
-               This  = MUTABLE_SV(temp);
+               other_hv = hv;
+               hv = temp;
                tied = TRUE;
            }
            if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
                other_tied = TRUE;
            
-           if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
+           if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
                RETPUSHNO;
 
            /* The hashes have the same number of keys, so it suffices
               to check that one is a subset of the other. */
-           (void) hv_iterinit(MUTABLE_HV(This));
-           while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
+           (void) hv_iterinit(hv);
+           while ( (he = hv_iternext(hv)) ) {
                I32 key_len;
                char * const key = hv_iterkey(he, &key_len);
                
                ++ this_key_count;
                
                if(!hv_exists(other_hv, key, key_len)) {
-                   (void) hv_iterinit(MUTABLE_HV(This));       /* reset iterator */
+                   (void) hv_iterinit(hv);     /* reset iterator */
                    RETPUSHNO;
                }
            }
@@ -4115,10 +4147,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;
+           HV *hv = MUTABLE_HV(SvRV(e));
 
            for (i = 0; i < other_len; ++i) {
                SV ** const svp = av_fetch(other_av, i, FALSE);
@@ -4127,38 +4160,65 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
 
                if (svp) {      /* ??? When can this not happen? */
                    key = SvPV(*svp, key_len);
-                   if (hv_exists(MUTABLE_HV(This), key, key_len))
+                   if (hv_exists(hv, key, key_len))
                        RETPUSHYES;
                }
            }
            RETPUSHNO;
        }
-       else if (SM_OTHER_REGEX) {
-           PMOP * const matcher = make_matcher(other_regex);
-           HE *he;
-
-           (void) hv_iterinit(MUTABLE_HV(This));
-           while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
-               if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
-                   (void) hv_iterinit(MUTABLE_HV(This));
-                   destroy_matcher(matcher);
-                   RETPUSHYES;
+       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+         sm_regex_hash:
+           {
+               PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+               HE *he;
+               HV *hv = MUTABLE_HV(SvRV(e));
+
+               (void) hv_iterinit(hv);
+               while ( (he = hv_iternext(hv)) ) {
+                   if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
+                       (void) hv_iterinit(hv);
+                       destroy_matcher(matcher);
+                       RETPUSHYES;
+                   }
                }
+               destroy_matcher(matcher);
+               RETPUSHNO;
            }
-           destroy_matcher(matcher);
-           RETPUSHNO;
        }
        else {
-           if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
+         sm_any_hash:
+           if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
                RETPUSHYES;
            else
                RETPUSHNO;
        }
     }
-    else if (SM_REF(PVAV)) {
-       if (SM_OTHER_REF(PVAV)) {
-           AV *other_av = MUTABLE_AV(SvRV(Other));
-           if (av_len(MUTABLE_AV(This)) != av_len(other_av))
+    /* ~~ @array */
+    else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
+       if (object_on_left) {
+           goto sm_any_array; /* Treat objects like scalars */
+       }
+       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+           AV * const other_av = MUTABLE_AV(SvRV(e));
+           const I32 other_len = av_len(other_av) + 1;
+           I32 i;
+
+           for (i = 0; i < other_len; ++i) {
+               SV ** const svp = av_fetch(other_av, i, FALSE);
+               char *key;
+               STRLEN key_len;
+
+               if (svp) {      /* ??? When can this not happen? */
+                   key = SvPV(*svp, key_len);
+                   if (hv_exists(MUTABLE_HV(SvRV(d)), key, key_len))
+                       RETPUSHYES;
+               }
+           }
+           RETPUSHNO;
+       }
+       if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+           AV *other_av = MUTABLE_AV(SvRV(d));
+           if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
                RETPUSHNO;
            else {
                I32 i;
@@ -4173,15 +4233,17 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                    (void) sv_2mortal(MUTABLE_SV(seen_other));
                }
                for(i = 0; i <= other_len; ++i) {
-                   SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
+                   SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
                    SV * const * const other_elem = av_fetch(other_av, i, FALSE);
 
                    if (!this_elem || !other_elem) {
                        if (this_elem || other_elem)
                            RETPUSHNO;
                    }
-                   else if (SM_SEEN_THIS(*this_elem)
-                        || SM_SEEN_OTHER(*other_elem))
+                   else if (hv_exists_ent(seen_this,
+                               sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
+                           hv_exists_ent(seen_other,
+                               sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
                    {
                        if (*this_elem != *other_elem)
                            RETPUSHNO;
@@ -4193,8 +4255,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                        (void)hv_store_ent(seen_other,
                                sv_2mortal(newSViv(PTR2IV(*other_elem))),
                                &PL_sv_undef, 0);
-                       PUSHs(*this_elem);
                        PUSHs(*other_elem);
+                       PUSHs(*this_elem);
                        
                        PUTBACK;
                        (void) do_smartmatch(seen_this, seen_other);
@@ -4207,124 +4269,85 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                RETPUSHYES;
            }
        }
-       else if (SM_OTHER_REGEX) {
-           PMOP * const matcher = make_matcher(other_regex);
-           const I32 this_len = av_len(MUTABLE_AV(This));
-           I32 i;
-
-           for(i = 0; i <= this_len; ++i) {
-               SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
-               if (svp && matcher_matches_sv(matcher, *svp)) {
-                   destroy_matcher(matcher);
-                   RETPUSHYES;
+       else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
+         sm_regex_array:
+           {
+               PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
+               const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
+               I32 i;
+
+               for(i = 0; i <= this_len; ++i) {
+                   SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+                   if (svp && matcher_matches_sv(matcher, *svp)) {
+                       destroy_matcher(matcher);
+                       RETPUSHYES;
+                   }
                }
+               destroy_matcher(matcher);
+               RETPUSHNO;
            }
-           destroy_matcher(matcher);
-           RETPUSHNO;
        }
-       else if (SvIOK(Other) || SvNOK(Other)) {
+       else if (!SvOK(d)) {
+           /* undef ~~ array */
+           const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
            I32 i;
 
-           for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
-               SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
-               if (!svp)
-                   continue;
-               
-               PUSHs(Other);
-               PUSHs(*svp);
-               PUTBACK;
-               if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
-                   (void) pp_i_eq();
-               else
-                   (void) pp_eq();
-               SPAGAIN;
-               if (SvTRUEx(POPs))
+           for (i = 0; i <= this_len; ++i) {
+               SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+               if (!svp || !SvOK(*svp))
                    RETPUSHYES;
            }
            RETPUSHNO;
        }
-       else if (SvPOK(Other)) {
-           const I32 this_len = av_len(MUTABLE_AV(This));
-           I32 i;
+       else {
+         sm_any_array:
+           {
+               I32 i;
+               const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
 
-           for(i = 0; i <= this_len; ++i) {
-               SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
-               if (!svp)
-                   continue;
-               
-               PUSHs(Other);
-               PUSHs(*svp);
-               PUTBACK;
-               (void) pp_seq();
-               SPAGAIN;
-               if (SvTRUEx(POPs))
-                   RETPUSHYES;
+               for (i = 0; i <= this_len; ++i) {
+                   SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
+                   if (!svp)
+                       continue;
+
+                   PUSHs(d);
+                   PUSHs(*svp);
+                   PUTBACK;
+                   /* infinite recursion isn't supposed to happen here */
+                   (void) do_smartmatch(NULL, NULL);
+                   SPAGAIN;
+                   if (SvTRUEx(POPs))
+                       RETPUSHYES;
+               }
+               RETPUSHNO;
            }
-           RETPUSHNO;
        }
     }
-    else if (!SvOK(d) || !SvOK(e)) {
-       if (!SvOK(d) && !SvOK(e))
-           RETPUSHYES;
-       else
-           RETPUSHNO;
-    }
-    else if (SM_REGEX) {
-       PMOP * const matcher = make_matcher(this_regex);
-
-       PUTBACK;
-       PUSHs(matcher_matches_sv(matcher, Other)
-           ? &PL_sv_yes
-           : &PL_sv_no);
-       destroy_matcher(matcher);
-       RETURN;
-    }
-    else if (SM_REF(PVCV)) {
-       I32 c;
-       /* This must be a null-prototyped sub, because we
-          already checked for the other kind. */
-       
-       ENTER;
-       SAVETMPS;
-       PUSHMARK(SP);
-       PUTBACK;
-       c = call_sv(This, G_SCALAR);
-       SPAGAIN;
-       if (c == 0)
-           PUSHs(&PL_sv_undef);
-       else if (SvTEMP(TOPs))
-           SvREFCNT_inc_void(TOPs);
+    /* ~~ qr// */
+    else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
+       if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
+           SV *t = d; d = e; e = t;
+           goto sm_regex_hash;
+       }
+       else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
+           SV *t = d; d = e; e = t;
+           goto sm_regex_array;
+       }
+       else {
+           PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
 
-       if (SM_OTHER_REF(PVCV)) {
-           /* This one has to be null-proto'd too.
-              Call both of 'em, and compare the results */
-           PUSHMARK(SP);
-           c = call_sv(SvRV(Other), G_SCALAR);
-           SPAGAIN;
-           if (c == 0)
-               PUSHs(&PL_sv_undef);
-           else if (SvTEMP(TOPs))
-               SvREFCNT_inc_void(TOPs);
-           FREETMPS;
-           LEAVE;
            PUTBACK;
-           return pp_eq();
+           PUSHs(matcher_matches_sv(matcher, d)
+                   ? &PL_sv_yes
+                   : &PL_sv_no);
+           destroy_matcher(matcher);
+           RETURN;
        }
-       
-       FREETMPS;
-       LEAVE;
-       RETURN;
     }
-    else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
-         ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
-    {
-       if (SvPOK(Other) && !looks_like_number(Other)) {
-           /* String comparison */
-           PUSHs(d); PUSHs(e);
-           PUTBACK;
-           return pp_seq();
-       }
-       /* Otherwise, numeric comparison */
+    /* ~~ X..Y TODO */
+    /* ~~ scalar */
+    else if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
+       /* numeric comparison */
        PUSHs(d); PUSHs(e);
        PUTBACK;
        if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
index 952da1b..8ac3590 100644 (file)
@@ -1800,7 +1800,7 @@ Use of uninitialized value in addition (+) at - line 4.
 use warnings 'uninitialized';
 my $v;
 my $fn = sub {};
-$v = 1 + ($fn ~~ 1);
+$v = 1 + (1 ~~ $fn);
 EXPECT
 Use of uninitialized value in addition (+) at - line 4.
 ########
index fcacd76..a7a33f7 100644 (file)
@@ -6,11 +6,17 @@ BEGIN {
     require './test.pl';
 }
 use strict;
+use warnings;
+no warnings 'uninitialized';
 
 use Tie::Array;
 use Tie::Hash;
 
 # Predeclare vars used in the tests:
+my @empty;
+my %empty;
+my @sparse; $sparse[2] = 2;
+
 my $deep1 = []; push @$deep1, \$deep1;
 my $deep2 = []; push @$deep2, \$deep2;
 
@@ -28,12 +34,14 @@ tie my %tied_hash, 'Tie::StdHash';
 }
 
 {
-    package Test::Object::CopyOverload;
-    sub new { bless { key => 1 } }
-    use overload '~~' => sub { my %hash = %{ $_[0] }; %hash ~~ $_[1] };
+    package Test::Object::WithOverload;
+    sub new { bless { key => 'magic' } }
+    use overload '~~' => sub { my %hash = %{ $_[0] }; $_[1] eq $hash{key} };
+    use overload '""' => sub { "stringified" };
+    use overload 'eq' => sub {"$_[0]" eq "$_[1]"};
 }
 
-our $ov_obj = Test::Object::CopyOverload->new;
+our $ov_obj = Test::Object::WithOverload->new;
 our $obj = Test::Object::NoOverload->new;
 
 my @keyandmore = qw(key and more);
@@ -50,263 +58,348 @@ while (<DATA>) {
     my ($yn, $left, $right, $note) = split /\t+/;
 
     local $::TODO = $note =~ /TODO/;
-    match_test($yn, $left, $right);
-    match_test($yn, $right, $left);
-}
 
-sub match_test {
-    my ($yn, $left, $right) = @_;
-
-    die "Bad test spec: ($yn, $left, $right)"
-       unless $yn eq "" || $yn eq "!" || $yn eq '@';
+    die "Bad test spec: ($yn, $left, $right)" if $yn =~ /[^!@=]/;
 
     my $tstr = "$left ~~ $right";
 
-    my $res = eval $tstr;
+    test_again:
+    my $res;
+    if ($note =~ /NOWARNINGS/) {
+       $res = eval "no warnings; $tstr";
+    }
+    else {
+       $res = eval $tstr;
+    }
 
     chomp $@;
 
-    if ( $yn eq '@' ) {
+    if ( $yn =~ /@/ ) {
        ok( $@ ne '', "$tstr dies" )
            and print "# \$\@ was: $@\n";
     } else {
-       my $test_name = $tstr . ($yn eq '!' ? " does not match" : " matches");
+       my $test_name = $tstr . ($yn =~ /!/ ? " does not match" : " matches");
        if ( $@ ne '' ) {
            fail($test_name);
            print "# \$\@ was: $@\n";
        } else {
-           ok( ($yn eq '!' xor $res), $test_name );
+           ok( ($yn =~ /!/ xor $res), $test_name );
        }
     }
-}
-
 
+    if ( $yn =~ s/=// ) {
+       $tstr = "$right ~~ $left";
+       goto test_again;
+    }
+}
 
 sub foo {}
 sub bar {42}
 sub gorch {42}
 sub fatal {die "fatal sub\n"}
 
-sub a_const() {die "const\n" if @_; "a constant"}
-sub b_const() {die "const\n" if @_; "a constant"}
+# to test constant folding
 sub FALSE() { 0 }
 sub TRUE() { 1 }
-sub TWO() { 1 }
+sub NOT_DEF() { undef }
 
 # Prefix character :
 #   - expected to match
 # ! - expected to not match
 # @ - expected to be a compilation failure
+# = - expected to match symmetrically (runs test twice)
 # Data types to test :
+#   undef
 #   Object-overloaded
 #   Object
-#   Code
-#   Code()
 #   Coderef
 #   Hash
 #   Hashref
 #   Array
 #   Arrayref
+#   Tied arrays and hashes
+#   Arrays that reference themselves
 #   Regex (// and qr//)
+#   Range
 #   Num
 #   Str
-#   undef
+# Other syntactic items of interest:
+#   Constants
+#   Values returned by a sub call
 __DATA__
-# OBJECT
-# - overloaded
-       $ov_obj         "key"
-!      $ov_obj         "foo"
-       $ov_obj         {"key" => 1}
-       $ov_obj         {"key" => 1, bar => 2}          TODO
-!      $ov_obj         {"foo" => 1}
-       $ov_obj         ["key" => 1]
-!      $ov_obj         ["foo" => 1]
-       $ov_obj         @keyandmore
-!      $ov_obj         @fooormore
-       $ov_obj         %keyandmore                     TODO
-!      $ov_obj         %fooormore
-       $ov_obj         /key/
-!      $ov_obj         /foo/
-       $ov_obj         qr/Key/i
-!      $ov_obj         qr/foo/
-       $ov_obj         sub { shift ~~ "key" }
-!      $ov_obj         sub { shift eq "key" }
-!      $ov_obj         sub { shift ~~ "foo" }
-!      $ov_obj         \&foo
-       $ov_obj         \&bar
-@      $ov_obj         \&fatal
-!      $ov_obj         FALSE
-!      $ov_obj         \&FALSE
+# Any ~~ undef
 !      $ov_obj         undef
-       $ov_obj         $ov_obj
+!      $obj            undef
+!      sub {}          undef
+!      %hash           undef
+!      \%hash          undef
+!      {}              undef
+!      @nums           undef
+!      \@nums          undef
+!      []              undef
+!      %tied_hash      undef
+!      @tied_nums      undef
+!      $deep1          undef
+!      /foo/           undef
+!      qr/foo/         undef
+!      21..30          undef
+!      189             undef
+!      "foo"           undef
+!      ""              undef
+!      !1              undef
+       undef           undef
+       (my $u)         undef
+       NOT_DEF         undef
+       &NOT_DEF        undef
+
+# Any ~~ object overloaded
+!      \&fatal         $ov_obj
+       'magic'         $ov_obj
+!      'not magic'     $ov_obj
+!      $obj            $ov_obj
+!      undef           $ov_obj
 
 # regular object
-@      $obj    "key"
-@      $obj    {"key" => 1}
-@      $obj    ["key" => 1]
-@      $obj    /key/
-@      $obj    qr/key/
-@      $obj    sub { 1 }
-@      $obj    sub { 0 }
-@      $obj    \&foo
-@      $obj    \&fatal
-@      $obj    FALSE
-@      $obj    \&FALSE
-!      $obj    undef
-@      $obj    $obj
-
-# CODE ref against argument
-#  - arg is code ref
-       \&foo           \&foo
-!      \&foo           sub {}
-!      \&foo           sub { "$_[0]" =~ /^CODE/ }
-!      \&foo           \&bar
-       \&fatal         \&fatal
-!      \&foo           \&fatal
-
-# - arg is not code ref
-       1       sub{shift}
-!      0       sub{shift}
-!      undef   sub{shift}
-       undef   sub{not shift}
-       FALSE   sub{not shift}
-       1       sub{scalar @_}
-       []      \&bar
-       {}      \&bar
-       qr//    \&bar
-!      []      \&foo
-!      {}      \&foo
-!      qr//    \&foo
-!      undef   \&foo
-       undef   \&bar
-@      undef   \&fatal
-@      1       \&fatal
-@      []      \&fatal
-@      "foo"   \&fatal
-@      qr//    \&fatal
-# pass argument by reference
-       @fooormore      sub{scalar @_ == 1}
-       @fooormore      sub{"@_" =~ /ARRAY/}
-       %fooormore      sub{"@_" =~ /HASH/}
+@      $obj            $obj
+@      $ov_obj         $obj
+@      \&fatal         $obj
+@      \&FALSE         $obj
+@      \&foo           $obj
+@      sub { 1 }       $obj
+@      sub { 0 }       $obj
+@      %keyandmore     $obj
+@      {"key" => 1}    $obj
+@      @fooormore      $obj
+@      ["key" => 1]    $obj
+@      /key/           $obj
+@      qr/key/         $obj
+@      "key"           $obj
+@      FALSE           $obj
+
+# object (overloaded or not) ~~ Any
+       $obj            qr/NoOverload/
+       $ov_obj         qr/^stringified$/
+       $ov_obj         "stringified"
+
+# ~~ Coderef
+       sub{0}          sub { ref $_[0] eq "CODE" }
+       %fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
+!      %fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
+       \%fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
+!      \%fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
+       +{%fooormore}   sub { $_[0] =~ /^(foo|or|more)$/ }
+!      +{%fooormore}   sub { $_[0] =~ /^(foo|or|less)$/ }
+       @fooormore      sub { $_[0] =~ /^(foo|or|more)$/ }
+!      @fooormore      sub { $_[0] =~ /^(foo|or|less)$/ }
+       \@fooormore     sub { $_[0] =~ /^(foo|or|more)$/ }
+!      \@fooormore     sub { $_[0] =~ /^(foo|or|less)$/ }
+       [@fooormore]    sub { $_[0] =~ /^(foo|or|more)$/ }
+!      [@fooormore]    sub { $_[0] =~ /^(foo|or|less)$/ }
+       %fooormore      sub{@_==1}
+       @fooormore      sub{@_==1}
+       "foo"           sub { $_[0] =~ /^(foo|or|more)$/ }
+!      "more"          sub { $_[0] =~ /^(foo|or|less)$/ }
        /fooormore/     sub{ref $_[0] eq 'Regexp'}
-
-# - null-prototyped subs
-       a_const         "a constant"
-       a_const         a_const
-       a_const         b_const
-       \&a_const       \&a_const
-!      \&a_const       \&b_const
-!      undef           \&FALSE
-       undef           \&TRUE
-!      0               \&FALSE
-       0               \&TRUE
-!      1               \&FALSE
-       1               \&TRUE
-       \&FALSE         \&FALSE
-!      \&FALSE         \&foo
-!      \&FALSE         \&bar
-!      \&TRUE          \&foo
-!      \&TRUE          \&bar
-!      \&TWO           \&foo
-!      \&TWO           \&bar
-       \&FALSE         \&FALSE
-
-# - non-null-prototyped subs
-!      \&bar           \&gorch
-       bar             gorch
-@      fatal           bar
+       qr/fooormore/   sub{ref $_[0] eq 'Regexp'}
+       1               sub{shift}
+!      0               sub{shift}
+!      undef           sub{shift}
+       undef           sub{not shift}
+       NOT_DEF         sub{not shift}
+       &NOT_DEF        sub{not shift}
+       FALSE           sub{not shift}
+       [1]             \&bar
+       {a=>1}          \&bar
+       qr//            \&bar
+!      [1]             \&foo
+!      {a=>1}          \&foo
+       $obj            sub { ref($_[0]) =~ /NoOverload/ }
+       $ov_obj         sub { ref($_[0]) =~ /WithOverload/ }
+# empty stuff matches, because the sub is never called:
+       []              \&foo
+       {}              \&foo
+       @empty          \&foo
+       %empty          \&foo
+!      qr//            \&foo
+!      undef           \&foo
+       undef           \&bar
+@      undef           \&fatal
+@      1               \&fatal
+@      [1]             \&fatal
+@      {a=>1}          \&fatal
+@      "foo"           \&fatal
+@      qr//            \&fatal
+# sub is not called on empty hashes / arrays
+       []              \&fatal
+       +{}             \&fatal
+       @empty          \&fatal
+       %empty          \&fatal
 
 # HASH ref against:
 #   - another hash ref
        {}              {}
-     {}              {1 => 2}
+=!     {}              {1 => 2}
        {1 => 2}        {1 => 2}
        {1 => 2}        {1 => 3}
-     {1 => 2}        {2 => 3}
-       \%main::        {map {$_ => 'x'} keys %main::}
+=!     {1 => 2}        {2 => 3}
+=      \%main::        {map {$_ => 'x'} keys %main::}
 
 #  - tied hash ref
-       \%hash          \%tied_hash
+=      \%hash          \%tied_hash
        \%tied_hash     \%tied_hash
+!=     {"a"=>"b"}      \%tied_hash
+=      %hash           %tied_hash
+       %tied_hash      %tied_hash
+!=     {"a"=>"b"}      %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)]
+#  (since this is symmetrical, tests as well hash~~array)
+=      [keys %main::]  \%::
+=      [qw[STDIN STDOUT]]      \%::
+=!     []              \%::
+=!     [""]            {}
+=!     []              {}
+=!     @empty          {}
+=      [undef]         {"" => 1}
+=      [""]            {"" => 1}
+=      ["foo"]         { foo => 1 }
+=      ["foo", "bar"]  { foo => 1 }
+=      ["foo", "bar"]  \%hash
+=      ["foo"]         \%hash
+=!     ["quux"]        \%hash
+=      [qw(foo quux)]  \%hash
+=      @fooormore      { foo => 1, or => 2, more => 3 }
+=      @fooormore      %fooormore
+=      @fooormore      \%fooormore
+=      \@fooormore     %fooormore
 
 #  - a regex
-       {foo => 1}      qr/^(fo[ox])$/
-!      +{0..99}        qr/[13579]$/
-
-#  - a string
-       +{foo => 1, bar => 2}   "foo"
-!      +{foo => 1, bar => 2}   "baz"
-
+=      qr/^(fo[ox])$/          {foo => 1}
+=      /^(fo[ox])$/            %fooormore
+=!     qr/[13579]$/            +{0..99}
+=!     qr/a*/                  {}
+=      qr/a*/                  {b=>2}
+=      qr/B/i                  {b=>2}
+=      /B/i                    {b=>2}
+=!     qr/a+/                  {b=>2}
+=      qr/^à/                 {"à"=>2}
+
+#  - a scalar
+       "foo"           +{foo => 1, bar => 2}
+       "foo"           %fooormore
+!      "baz"           +{foo => 1, bar => 2}
+!      "boz"           %fooormore
+!      1               +{foo => 1, bar => 2}
+!      1               %fooormore
+       1               { 1 => 3 }
+       1.0             { 1 => 3 }
+!      "1.0"           { 1 => 3 }
+!      "1.0"           { 1.0 => 3 }
+       "1.0"           { "1.0" => 3 }
+       "à"            { "à" => "À" }
+
+#  - undef
+!      undef           { hop => 'zouu' }
+!      undef           %hash
+!      undef           +{"" => "empty key"}
+!      undef           {}
 
 # ARRAY ref against:
 #  - another array ref
        []                      []
-     []                      [1]
+=!     []                      [1]
        [["foo"], ["bar"]]      [qr/o/, qr/a/]
+!      [["foo"], ["bar"]]      [qr/ARRAY/, qr/ARRAY/]
        ["foo", "bar"]          [qr/o/, qr/a/]
+!      [qr/o/, qr/a/]          ["foo", "bar"]
+       ["foo", "bar"]          [["foo"], ["bar"]]
 !      ["foo", "bar"]          [qr/o/, "foo"]
+       ["foo", undef, "bar"]   [qr/o/, undef, "bar"]
+       ["foo", undef, "bar"]   [qr/o/, "",    "bar"]
+!      ["foo", "", "bar"]      [qr/o/, undef, "bar"]
        $deep1                  $deep1
+       @$deep1                 @$deep1
 !      $deep1                  $deep2
 
-       \@nums                  \@tied_nums
+=      \@nums                  \@tied_nums
+=      @nums                   \@tied_nums
+=      \@nums                  @tied_nums
+=      @nums                   @tied_nums
+
+#  - an object
+!      $obj            @fooormore
+       $obj            [sub{ref shift}]
 
 #  - a regex
-       [qw(foo bar baz quux)]  qr/x/
-!      [qw(foo bar baz quux)]  qr/y/
+=      qr/x/           [qw(foo bar baz quux)]
+=!     qr/y/           [qw(foo bar baz quux)]
+=      /x/             [qw(foo bar baz quux)]
+=!     /y/             [qw(foo bar baz quux)]
+=      /FOO/i          @fooormore
+=!     /bar/           @fooormore
 
 # - a number
-       [qw(1foo 2bar)]         2
-       [qw(foo 2)]             2
-       [qw(foo 2)]             2.0_0e+0
-!      [qw(1foo bar2)]         2
+       2               [qw(1.00 2.00)]
+       2               [qw(foo 2)]
+       2.0_0e+0        [qw(foo 2)]
+!      2               [qw(1foo bar2)]
 
 # - a string
-!      [qw(1foo 2bar)]         "2"
-       [qw(1foo 2bar)]         "2bar"
+!      "2"             [qw(1foo 2bar)]
+       "2bar"          [qw(1foo 2bar)]
+
+# - undef
+       undef           [1, 2, undef, 4]
+!      undef           [1, 2, [undef], 4]
+!      undef           @fooormore
+       undef           @sparse
+
+# - nested arrays and ~~ distributivity
+       11              [[11]]
+!      11              [[12]]
+       "foo"           [{foo => "bar"}]
+!      "bar"           [{foo => "bar"}]
 
 # Number against number
        2               2
+       20              2_0
 !      2               3
        0               FALSE
        3-2             TRUE
+       undef           0
 
 # Number against string
-       2               "2"
-       2               "2.0"
+=      2               "2"
+=      2               "2.0"
 !      2               "2bananas"
-!      2_3             "2_3"
+!=     2_3             "2_3"           NOWARNINGS
        FALSE           "0"
 
 # Regex against string
-       qr/x/           "x"
-!      qr/y/           "x"
+       "x"             qr/x/
+!      "x"             qr/y/
 
 # Regex against number
        12345           qr/3/
+!      12345           qr/7/
 
+# array/hash against string
+       @fooormore      "".\@fooormore
+!      @keyandmore     "".\@fooormore
+       %fooormore      "".\%fooormore
+!      %keyandmore     "".\%fooormore
 
 # Test the implicit referencing
-       @nums           7
+       7               @nums
        @nums           \@nums
 !      @nums           \\@nums
        @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
@@ -318,20 +411,3 @@ __DATA__
        @nums           {  1, '',  2, '' }
        @nums           {  1, '', 12, '' }
 !      @nums           { 11, '', 12, '' }
-
-# UNDEF
-!      3               undef
-!      1               undef
-!      []              undef
-!      {}              undef
-!      \%::main        undef
-!      [1,2]           undef
-!      %hash           undef
-!      @nums           undef
-!      "foo"           undef
-!      ""              undef
-!      !1              undef
-!      \&foo           undef
-!      sub { }         undef
-       undef           undef
-       $::undef        undef
index 7e168d2..3e65bf4 100644 (file)
@@ -16,7 +16,6 @@ use Test::More tests => 122;
               
 
 use feature 'switch';
-no warnings "numeric";
 
 eval { continue };
 like($@, qr/^Can't "continue" outside/, "continue outside");
@@ -133,14 +132,16 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
     is($ok, 1, "Given(0) when($undef++)");
 }
 {
-    my $ok = 1;
-    given (undef) { when(0) {$ok = 0} }
+    no warnings "uninitialized";
+    my $ok = 0;
+    given (undef) { when(0) {$ok = 1} }
     is($ok, 1, "Given(undef) when(0)");
 }
 {
+    no warnings "uninitialized";
     my $undef;
-    my $ok = 1;
-    given ($undef) { when(0) {$ok = 0} }
+    my $ok = 0;
+    given ($undef) { when(0) {$ok = 1} }
     is($ok, 1, 'Given($undef) when(0)');
 }
 ########
@@ -156,14 +157,16 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
     is($ok, 1, 'Given("") when($undef)');
 }
 {
-    my $ok = 1;
-    given (undef) { when("") {$ok = 0} }
+    no warnings "uninitialized";
+    my $ok = 0;
+    given (undef) { when("") {$ok = 1} }
     is($ok, 1, 'Given(undef) when("")');
 }
 {
+    no warnings "uninitialized";
     my $undef;
-    my $ok = 1;
-    given ($undef) { when("") {$ok = 0} }
+    my $ok = 0;
+    given ($undef) { when("") {$ok = 1} }
     is($ok, 1, 'Given($undef) when("")');
 }
 ########
@@ -428,11 +431,11 @@ sub check_outside1 { is($_, "outside", "\$_ lexically scoped") }
 }
 
 # Sub and method calls
-sub bar {"bar"}
+sub notfoo {"bar"}
 {
     my $ok = 0;
     given("foo") {
-       when(bar()) {$ok = 1}
+       when(notfoo()) {$ok = 1}
     }
     ok($ok, "Sub call acts as boolean")
 }
@@ -440,7 +443,7 @@ sub bar {"bar"}
 {
     my $ok = 0;
     given("foo") {
-       when(main->bar()) {$ok = 1}
+       when(main->notfoo()) {$ok = 1}
     }
     ok($ok, "Class-method call acts as boolean")
 }
@@ -449,7 +452,7 @@ sub bar {"bar"}
     my $ok = 0;
     my $obj = bless [];
     given("foo") {
-       when($obj->bar()) {$ok = 1}
+       when($obj->notfoo()) {$ok = 1}
     }
     ok($ok, "Object-method call acts as boolean")
 }
@@ -510,76 +513,45 @@ sub bar {"bar"}
 }
 
 {
-    my $ok = 0;
-    given("foo") {
-       when((1 == $ok) || "foo") {
-           $ok = 1;
+    my $n = 0;
+    for my $l qw(a b c d) {
+       given ($l) {
+           when ($_ eq "b" .. $_ eq "c") { $n = 1 }
+           default { $n = 0 }
        }
+       ok(($n xor $l =~ /[ad]/), 'when(E1..E2) evaluates in boolean context');
     }
-    ok($ok, '((1 == $ok) || "foo") smartmatched');
 }
 
-TODO: {
-    local $TODO = "RT #50538: when( \@n && \%n ) fails to smart match";
-    { # this should smart match on each side of &&
-       my @n = qw(fred barney betty);
-       my @m = @n;
-       
-       my $ok = 0;
-       given( "fred" ) {
-       when( @n ) {
-               $ok++; continue;
-       }
-       when( @m ) {
-               $ok++; continue;
-       }
-       when( @m && @n ) {
-               $ok++;
-       }
+{
+    my $n = 0;
+    for my $l qw(a b c d) {
+       given ($l) {
+           when ($_ eq "b" ... $_ eq "c") { $n = 1 }
+           default { $n = 0 }
        }
-
-       is($ok, 3, '(@n && @m) smart-matched'); 
+       ok(($n xor $l =~ /[ad]/), 'when(E1...E2) evaluates in boolean context');
     }
+}
 
-    { # this should smart match on each side of &&
-       my @n = qw(fred barney betty);
-       my %n = map { $_, 1 } @n;
-       
-       my $ok = 0;
-       given( "fred" ) {
-       when( @n ) {
-               $ok++; continue;
-       }
-       when( %n ) {
-               $ok++; continue;
-       }
-       when( @n && %n ) {
-               $ok++;
-       }
+{
+    my $ok = 0;
+    given("foo") {
+       when((1 == $ok) || "foo") {
+           $ok = 1;
        }
-
-       is($ok, 3, '(@n && %n) smart-matched'); 
     }
+    ok($ok, '((1 == $ok) || "foo") smartmatched');
+}
 
-    { # this should smart match on each side of &&
-       my %n = map { $_, 1 } qw(fred barney betty);
-       my %m = %n;
-       
-       my $ok = 0;
-       given( "fred" ) {
-       when( %m ) {
-               $ok++; continue;
-       }
-       when( %n ) {
-               $ok++; continue;
-       }
-       when( %m && %n ) {
-               $ok++;
-       }
+{
+    my $ok = 0;
+    given("foo") {
+       when((1 == $ok || undef) // "foo") {
+           $ok = 1;
        }
-
-       is($ok, 3, '(%m && %n) smart-matched'); 
     }
+    ok($ok, '((1 == $ok || undef) // "foo") smartmatched');
 }
 
 # Make sure we aren't invoking the get-magic more than once
@@ -659,6 +631,7 @@ my $f = tie my $v, "FetchCounter";
     my $ok;
     $v = undef;
     is($f->count(), 0, "Sanity check: $test_name");
+    no warnings "uninitialized";
     given(my $undef) {
        when(sub{0}->()) {}
        when("21")  {}
@@ -761,20 +734,19 @@ my $f = tie my $v, "FetchCounter";
 
 # Code references
 {
-    no warnings "redefine";
     my $called_foo = 0;
-    sub foo {$called_foo = 1}
+    sub foo {$called_foo = 1; "@_" eq "foo"}
     my $called_bar = 0;
-    sub bar {$called_bar = 1}
+    sub bar {$called_bar = 1; "@_" eq "bar"}
     my ($matched_foo, $matched_bar) = (0, 0);
-    given(\&foo) {
+    given("foo") {
        when(\&bar) {$matched_bar = 1}
        when(\&foo) {$matched_foo = 1}
     }
-    is($called_foo, 0,  "Code ref comparison: foo not called");
-    is($called_bar, 0,  "Code ref comparison: bar not called");
-    is($matched_bar, 0, "Code ref didn't match different one");
-    is($matched_foo, 1, "Code ref did match itself");
+    is($called_foo, 1,  "foo() was called");
+    is($called_bar, 1,  "bar() was called");
+    is($matched_bar, 0, "bar didn't match");
+    is($matched_foo, 1, "foo did match");
 }
 
 sub contains_x {
@@ -809,6 +781,7 @@ SKIP: {
     { package OverloadTest;
 
       use overload '""' => sub{"string value of obj"};
+      use overload 'eq' => sub{"$_[0]" eq "$_[1]"};
 
       use overload "~~" => sub {
          my ($self, $other, $reversed) = @_;
@@ -843,11 +816,8 @@ SKIP: {
            default {$matched = 0}
        }
     
-       is($obj->{called},  1, "$test: called");
-       ok($matched, "$test: matched");
-       is($obj->{left}, "string value of obj", "$test: left");
-       is($obj->{right}, "other arg", "$test: right");
-       ok(!$obj->{reversed}, "$test: not reversed");
+       is($obj->{called}, 0, "$test: called");
+       ok(!$matched, "$test: not matched");
     }
 
     {
@@ -858,11 +828,8 @@ SKIP: {
            when ("other arg") {$matched = 1}
        }
     
-       is($obj->{called},  1, "$test: called");
+       is($obj->{called}, 0, "$test: called");
        ok(!$matched, "$test: not matched");
-       is($obj->{left}, "string value of obj", "$test: left");
-       is($obj->{right}, "other arg", "$test: right");
-       ok(!$obj->{reversed}, "$test: not reversed");
     }
 
     {