X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=0eb513f9a354ff366d12a605f72487e125e64498;hb=17eef65c2fb9a95edf9064575d3413b4ec8219b7;hp=5096b3a426d99b7bf527580f742940202e4cacea;hpb=f9bddea7d2a0d824366014c8ee6ba57e7dedd8c3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 5096b3a..0eb513f 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -511,8 +511,7 @@ PP(pp_formline) if (!targ_is_utf8 && DO_UTF8(tmpForm)) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -695,8 +694,8 @@ PP(pp_formline) if (!targ_is_utf8) { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); *t = '\0'; - sv_utf8_upgrade(PL_formtarget); - SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1); + sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, + fudge + 1); t = SvEND(PL_formtarget); targ_is_utf8 = TRUE; } @@ -807,7 +806,7 @@ PP(pp_formline) t - SvPVX_const(PL_formtarget)); targ_is_utf8 = TRUE; /* Don't need get magic. */ - sv_utf8_upgrade_flags(PL_formtarget, 0); + sv_utf8_upgrade_nomg(PL_formtarget); } else { SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget)); @@ -1252,9 +1251,9 @@ PP(pp_flop) static const char * const context_name[] = { "pseudo-block", - "when", + NULL, /* CXt_WHEN never actually needs "block" */ NULL, /* CXt_BLOCK never actually needs "block" */ - "given", + NULL, /* CXt_GIVEN never actually needs "block" */ NULL, /* CXt_LOOP_FOR never actually needs "loop" */ NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */ NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */ @@ -1281,8 +1280,6 @@ S_dopoptolabel(pTHX_ const char *label) case CXt_FORMAT: case CXt_EVAL: case CXt_NULL: - case CXt_GIVEN: - case CXt_WHEN: if (ckWARN(WARN_EXITING)) Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s", context_name[CxTYPE(cx)], OP_NAME(PL_op)); @@ -1752,9 +1749,8 @@ PP(pp_caller) const int off = AvARRAY(ary) - AvALLOC(ary); if (!PL_dbargs) { - GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV); - PL_dbargs = GvAV(gv_AVadd(tmpgv)); - GvMULTI_on(tmpgv); + PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI, + SVt_PVAV))); AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ } @@ -1779,7 +1775,7 @@ PP(pp_caller) /* Get the bit mask for $warnings::Bits{all}, because * it could have been extended by warnings::register */ SV **bits_all; - HV * const bits = get_hv("warnings::Bits", FALSE); + HV * const bits = get_hv("warnings::Bits", 0); if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) { mask = newSVsv(*bits_all); } @@ -2576,7 +2572,7 @@ PP(pp_goto) if (PERLDB_SUB) { /* Checking curstash breaks DProf. */ Perl_get_db_sub(aTHX_ NULL, cv); if (PERLDB_GOTO) { - CV * const gotocv = get_cv("DB::goto", FALSE); + CV * const gotocv = get_cvs("DB::goto", 0); if (gotocv) { PUSHMARK( PL_stack_sp ); call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG); @@ -2627,6 +2623,8 @@ PP(pp_goto) case CXt_LOOP_LAZYSV: case CXt_LOOP_FOR: case CXt_LOOP_PLAIN: + case CXt_GIVEN: + case CXt_WHEN: gotoprobe = cx->blk_oldcop->op_sibling; break; case CXt_SUBST: @@ -3099,7 +3097,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) /* Register with debugger: */ if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { - CV * const cv = get_cv("DB::postponed", FALSE); + CV * const cv = get_cvs("DB::postponed", 0); if (cv) { dSP; PUSHMARK(SP); @@ -3258,6 +3256,11 @@ PP(pp_require) Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL); LEAVE; } + /* If a version >= 5.11.0 is requested, strictures are on by default! */ + if (PL_compcv && + vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) { + PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS); + } RETPUSHYES; } @@ -3305,17 +3308,6 @@ PP(pp_require) tryname = name; tryrsfp = doopen_pm(name, len); } -#ifdef MACOS_TRADITIONAL - if (!tryrsfp) { - char newname[256]; - - MacPerl_CanonDir(name, newname, 1); - if (path_is_absolute(newname)) { - tryname = newname; - tryrsfp = doopen_pm(newname, strlen(newname)); - } - } -#endif if (!tryrsfp) { AV * const ar = GvAVn(PL_incgv); I32 i; @@ -3446,12 +3438,6 @@ PP(pp_require) } else { if (!path_is_absolute(name) -#ifdef MACOS_TRADITIONAL - /* We consider paths of the form :a:b ambiguous and interpret them first - as global then as local - */ - || (*name == ':' && name[1] != ':' && strchr(name+2, ':')) -#endif ) { const char *dir; STRLEN dirlen; @@ -3463,21 +3449,14 @@ PP(pp_require) dirlen = 0; } -#ifdef MACOS_TRADITIONAL - char buf1[256]; - char buf2[256]; - - MacPerl_CanonDir(name, buf2, 1); - Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':')); -#else -# ifdef VMS +#ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, NULL)) == NULL) continue; sv_setpv(namesv, unixdir); sv_catpv(namesv, unixname); -# else -# ifdef __SYMBIAN32__ +#else +# ifdef __SYMBIAN32__ if (PL_origfilename[0] && PL_origfilename[1] == ':' && !(dir[0] && dir[1] == ':')) @@ -3489,7 +3468,7 @@ PP(pp_require) Perl_sv_setpvf(aTHX_ namesv, "%s\\%s", dir, name); -# else +# else /* The equivalent of Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name); but without the need to parse the format string, or @@ -3510,15 +3489,16 @@ PP(pp_require) /* Don't even actually have to turn SvPOK_on() as we access it directly with SvPVX() below. */ } -# endif # endif #endif TAINT_PROPER("require"); tryname = SvPVX_const(namesv); tryrsfp = doopen_pm(tryname, SvCUR(namesv)); if (tryrsfp) { - if (tryname[0] == '.' && tryname[1] == '/') - tryname += 2; + if (tryname[0] == '.' && tryname[1] == '/') { + ++tryname; + while (*++tryname == '/'); + } break; } else if (errno == EMFILE) @@ -3588,10 +3568,7 @@ PP(pp_require) SAVEHINTS(); PL_hints = 0; - if (PL_compiling.cop_hints_hash) { - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = NULL; - } + hv_clear(GvHV(PL_hintgv)); SAVECOMPILEWARNINGS(); if (PL_dowarn & G_WARN_ALL_ON) @@ -3696,8 +3673,11 @@ PP(pp_entereval) introduced within evals. See force_ident(). GSAR 96-10-12 */ SAVEHINTS(); PL_hints = PL_op->op_targ; - if (saved_hh) + if (saved_hh) { + /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); GvHV(PL_hintgv) = saved_hh; + } SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); if (PL_compiling.cop_hints_hash) { @@ -3739,7 +3719,9 @@ PP(pp_entereval) } else { /* We have already left the scope set up earler thanks to the LEAVE in doeval(). */ - if (PERLDB_SAVESRC_INVALID) { + if (was != PL_breakable_sub_gen /* Some subs defined here. */ + ? (PERLDB_LINE || PERLDB_SAVESRC) + : PERLDB_SAVESRC_INVALID) { /* Retain the filegv we created. */ } else { (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD); @@ -3927,13 +3909,7 @@ PP(pp_entergiven) ENTER; SAVETMPS; - if (PL_op->op_targ == 0) { - SV ** const defsv_p = &GvSV(PL_defgv); - *defsv_p = newSVsv(POPs); - SAVECLEARSV(*defsv_p); - } - else - sv_setsv(PAD_SV(PL_op->op_targ), POPs); + sv_setsv(PAD_SV(PL_op->op_targ), POPs); PUSHBLOCK(cx, CXt_GIVEN, SP); PUSHGIVEN(cx); @@ -4011,6 +3987,7 @@ S_destroy_matcher(pTHX_ PMOP *matcher) /* Do a smart match */ PP(pp_smartmatch) { + DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n")); return do_smartmatch(NULL, NULL); } @@ -4023,54 +4000,26 @@ 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) + /* First of all, handle overload magic of the rightmost argument */ + if (SvAMAGIC(e)) { + SV * tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); -# define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \ - sv_2mortal(newSViv(PTR2IV(sv))), 0) + tmpsv = amagic_call(d, e, smart_amg, 0); + if (tmpsv) { + SPAGAIN; + (void)POPs; + SETs(tmpsv); + RETURN; + } + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; continuing...\n")); + } - tryAMAGICbinSET(smart, 0); - SP -= 2; /* Pop the values */ /* Take care only to invoke mg_get() once for each argument. @@ -4086,72 +4035,156 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SvGMAGICAL(e)) e = sv_mortalcopy(e); - if (SM_OBJECT) + /* ~~ undef */ + if (!SvOK(e)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-undef\n")); + if (SvOK(d)) + RETPUSHNO; + else + RETPUSHYES; + } + + if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Object\n")); Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation"); + } + if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP)) + object_on_left = TRUE; - if (SM_CV_NEP) { + /* ~~ 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); + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-CodeRef\n")); + if (numkeys == 0) + RETPUSHYES; + while ( (he = hv_iternext(hv)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing hash key...\n")); + 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); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-CodeRef\n")); + if (len == -1) + RETPUSHYES; + for (i = 0; i <= len; ++i) { + SV * const * const svp = av_fetch(av, i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing array element...\n")); + 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: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-CodeRef\n")); + 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)) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash ($a undef)\n")); + 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)); + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Hash\n")); /* 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))) ) { - I32 key_len; - char * const key = hv_iterkey(he, &key_len); - + (void) hv_iterinit(hv); + while ( (he = hv_iternext(hv)) ) { + SV *key = hv_iterkeysv(he); + + DEBUG_M(Perl_deb(aTHX_ " comparing hash key...\n")); ++ this_key_count; - if(!hv_exists(other_hv, key, key_len)) { - (void) hv_iterinit(MUTABLE_HV(This)); /* reset iterator */ + if(!hv_exists_ent(other_hv, key, 0)) { + (void) hv_iterinit(hv); /* reset iterator */ RETPUSHNO; } } @@ -4169,50 +4202,79 @@ 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)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Hash\n")); for (i = 0; i < other_len; ++i) { SV ** const svp = av_fetch(other_av, i, FALSE); - char *key; - STRLEN key_len; - + DEBUG_M(Perl_deb(aTHX_ " checking for key existence...\n")); if (svp) { /* ??? When can this not happen? */ - key = SvPV(*svp, key_len); - if (hv_exists(MUTABLE_HV(This), key, key_len)) + if (hv_exists_ent(hv, *svp, 0)) 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) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Hash\n")); + 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)) ) { + DEBUG_M(Perl_deb(aTHX_ " testing key against pattern...\n")); + 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: + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Hash\n")); + 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; + + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Array\n")); + for (i = 0; i < other_len; ++i) { + SV ** const svp = av_fetch(other_av, i, FALSE); + + DEBUG_M(Perl_deb(aTHX_ " testing for key existence...\n")); + if (svp) { /* ??? When can this not happen? */ + if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0)) + RETPUSHYES; + } + } + RETPUSHNO; + } + if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + AV *other_av = MUTABLE_AV(SvRV(d)); + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Array\n")); + if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av)) RETPUSHNO; else { I32 i; @@ -4227,15 +4289,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; @@ -4247,12 +4311,14 @@ 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; + DEBUG_M(Perl_deb(aTHX_ " recursively comparing array element...\n")); (void) do_smartmatch(seen_this, seen_other); SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); if (!SvTRUEx(POPs)) RETPUSHNO; @@ -4261,124 +4327,124 @@ 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) { + DEBUG_M(Perl_deb(aTHX_ " applying rule Regex-Array\n")); + 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); + DEBUG_M(Perl_deb(aTHX_ " testing element against pattern...\n")); + 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)) + DEBUG_M(Perl_deb(aTHX_ " applying rule Undef-Array\n")); + for (i = 0; i <= this_len; ++i) { + SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE); + DEBUG_M(Perl_deb(aTHX_ " testing for undef element...\n")); + 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; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Array\n")); + 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 */ + DEBUG_M(Perl_deb(aTHX_ " recursively testing array element...\n")); + (void) do_smartmatch(NULL, NULL); + SPAGAIN; + DEBUG_M(Perl_deb(aTHX_ " recursion finished\n")); + 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); + /* ~~ 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; + DEBUG_M(Perl_deb(aTHX_ " applying rule Hash-Regex\n")); + goto sm_regex_hash; + } + else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) { + SV *t = d; d = e; e = t; + DEBUG_M(Perl_deb(aTHX_ " applying rule Array-Regex\n")); + goto sm_regex_array; + } + else { + PMOP * const matcher = make_matcher((REGEXP*) SvRV(e)); - PUTBACK; - PUSHs(matcher_matches_sv(matcher, Other) - ? &PL_sv_yes - : &PL_sv_no); - destroy_matcher(matcher); - RETURN; + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Regex\n")); + PUTBACK; + PUSHs(matcher_matches_sv(matcher, d) + ? &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); + /* ~~ scalar */ + /* See if there is overload magic on left */ + else if (object_on_left && SvAMAGIC(d)) { + SV *tmpsv; + DEBUG_M(Perl_deb(aTHX_ " applying rule Object-Any\n")); + DEBUG_M(Perl_deb(aTHX_ " attempting overload\n")); + PUSHs(d); PUSHs(e); PUTBACK; - c = call_sv(This, G_SCALAR); - SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_undef); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - - 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); + tmpsv = amagic_call(d, e, smart_amg, AMGf_noright); + if (tmpsv) { SPAGAIN; - if (c == 0) - PUSHs(&PL_sv_undef); - else if (SvTEMP(TOPs)) - SvREFCNT_inc_void(TOPs); - FREETMPS; - LEAVE; - PUTBACK; - return pp_eq(); + (void)POPs; + SETs(tmpsv); + RETURN; } - - FREETMPS; - LEAVE; - RETURN; + SP -= 2; + DEBUG_M(Perl_deb(aTHX_ " failed to run overload method; falling back...\n")); + goto sm_any_scalar; } - 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 */ + else if (!SvOK(d)) { + /* undef ~~ scalar ; we already know that the scalar is SvOK */ + DEBUG_M(Perl_deb(aTHX_ " applying rule undef-Any\n")); + RETPUSHNO; + } + else + sm_any_scalar: + if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) { + DEBUG_M(if (SvNIOK(e)) + Perl_deb(aTHX_ " applying rule Any-Num\n"); + else + Perl_deb(aTHX_ " applying rule Num-numish\n"); + ); + /* numeric comparison */ PUSHs(d); PUSHs(e); PUTBACK; if (CopHINTS_get(PL_curcop) & HINT_INTEGER) @@ -4393,6 +4459,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } /* As a last resort, use string comparison */ + DEBUG_M(Perl_deb(aTHX_ " applying rule Any-Any\n")); PUSHs(d); PUSHs(e); PUTBACK; return pp_seq(); @@ -4930,8 +4997,12 @@ S_path_is_absolute(const char *name) PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE; if (PERL_FILE_IS_ABSOLUTE(name) -#ifdef MACOS_TRADITIONAL - || (*name == ':') +#ifdef WIN32 + || (*name == '.' && ((name[1] == '/' || + (name[1] == '.' && name[2] == '/')) + || (name[1] == '\\' || + ( name[1] == '.' && name[2] == '\\'))) + ) #else || (*name == '.' && (name[1] == '/' || (name[1] == '.' && name[2] == '/')))