In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/56d86adf5b9b1c05ea2f24c084864c043d30d101?hp=f7bbabd3deb33ca111eb6b17f0252ad07f079f16>
- Log ----------------------------------------------------------------- commit 56d86adf5b9b1c05ea2f24c084864c043d30d101 Merge: f7bbabd... 289d21b... Author: Rafael Garcia-Suarez <[email protected]> Date: Wed May 13 15:05:49 2009 +0200 Merge branch 'smartmatch' into blead ----------------------------------------------------------------------- Summary of changes: lib/overload.pm | 14 +- op.c | 8 +- pod/perlsyn.pod | 97 ++++++----- pod/perltodo.pod | 49 ------ pp_ctl.c | 431 +++++++++++++++++++++++++---------------------- t/lib/warnings/9uninit | 2 +- t/op/smartmatch.t | 436 ++++++++++++++++++++++++++++-------------------- t/op/switch.t | 143 ++++++---------- 8 files changed, 611 insertions(+), 569 deletions(-) diff --git a/lib/overload.pm b/lib/overload.pm index da114c5..a384568 100644 --- a/lib/overload.pm +++ b/lib/overload.pm @@ -138,6 +138,7 @@ sub mycan { # Real can would leave stubs. iterators => '<>', filetest => "-X", dereferencing => '${} @{} %{} &{} *{}', + matching => '~~', special => 'nomethod fallback ='); use warnings::register; @@ -448,6 +449,11 @@ treated as a filename. This overload was introduced in perl 5.12. +=item * I<Matching> + +The key C<"~~"> allows you to override the smart matching used by +the switch construct. See L<feature>. + =item * I<Dereferencing> '${}', '@{}', '%{}', '&{}', '*{}'. @@ -464,7 +470,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>>. @@ -489,6 +495,7 @@ A computer-readable form of the above table is available in the hash iterators => '<>', filetest => '-X', dereferencing => '${} @{} %{} &{} *{}', + matching => '~~', special => 'nomethod fallback =' =head2 Inheritance and overloading @@ -585,11 +592,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 63530b3..8851c06 100644 --- a/op.c +++ b/op.c @@ -5176,6 +5176,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: @@ -5191,7 +5192,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: @@ -5216,6 +5216,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: @@ -5224,7 +5226,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; diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 28bb824..94a5677 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -534,24 +534,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); } @@ -585,7 +580,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 * @@ -598,26 +593,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 @@ -677,47 +682,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 @@ -727,7 +736,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 diff --git a/pod/perltodo.pod b/pod/perltodo.pod index b01522a..73495cb 100644 --- a/pod/perltodo.pod +++ b/pod/perltodo.pod @@ -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 diff --git a/pp_ctl.c b/pp_ctl.c index d85ec11..27a4c03 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -3997,54 +3997,20 @@ 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++ */ - 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) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP) \ - && (this_regex = (REGEXP*) This) \ - && (Other = e)) \ - || \ - (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP) \ - && (this_regex = (REGEXP*) This) \ - && (Other = d)) ) - - -# define SM_OBJECT ( \ - (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) \ - || \ - (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) ) \ - -# define SM_OTHER_REF(type) \ - (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type) - -# define SM_OTHER_REGEX (SvROK(Other) \ - && (SvTYPE(SvRV(Other)) == SVt_REGEXP) \ - && (other_regex = (REGEXP*) SvRV(Other))) - -# 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. @@ -4060,76 +4026,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; } } @@ -4147,10 +4183,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); @@ -4159,38 +4196,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; @@ -4205,15 +4269,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; @@ -4225,8 +4291,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); @@ -4239,124 +4305,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) diff --git a/t/lib/warnings/9uninit b/t/lib/warnings/9uninit index e0b186a..50db322 100644 --- a/t/lib/warnings/9uninit +++ b/t/lib/warnings/9uninit @@ -1815,7 +1815,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. ######## diff --git a/t/op/smartmatch.t b/t/op/smartmatch.t index fcacd76..a7a33f7 100644 --- a/t/op/smartmatch.t +++ b/t/op/smartmatch.t @@ -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 s...@_==1} + @fooormore s...@_==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 diff --git a/t/op/switch.t b/t/op/switch.t index a4977c7..55ed457 100644 --- a/t/op/switch.t +++ b/t/op/switch.t @@ -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"); } { -- Perl5 Master Repository
