X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/941a98a017bebaf9418c346af5601481227ecf3c..cd4eab350f31b452f88e849e0c9d1309692f544f:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index 1a0245a..5cbf0a8 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -113,7 +113,7 @@ PP(pp_regcomp) tmpstr = POPs; if (SvROK(tmpstr)) { - SV *sv = SvRV(tmpstr); + SV * const sv = SvRV(tmpstr); if(SvMAGICAL(sv)) mg = mg_find(sv, PERL_MAGIC_qr); } @@ -125,16 +125,24 @@ PP(pp_regcomp) else { STRLEN len; const char *t = SvPV_const(tmpstr, len); + regexp * const re = PM_GETRE(pm); /* Check against the last compiled regexp. */ - if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp || - PM_GETRE(pm)->prelen != (I32)len || - memNE(PM_GETRE(pm)->precomp, t, len)) + if (!re || !re->precomp || re->prelen != (I32)len || + memNE(re->precomp, t, len)) { - if (PM_GETRE(pm)) { - ReREFCNT_dec(PM_GETRE(pm)); + const regexp_engine *eng = re ? re->engine : NULL; + + if (re) { + ReREFCNT_dec(re); PM_SETRE(pm, NULL); /* crucial if regcomp aborts */ + } else if (PL_curcop->cop_hints_hash) { + SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0, + "regcomp", 7, 0, 0); + if (ptr && SvIOK(ptr) && SvIV(ptr)) + eng = INT2PTR(regexp_engine*,SvIV(ptr)); } + if (PL_op->op_flags & OPf_SPECIAL) PL_reginterp_cnt = I32_MAX; /* Mark as safe. */ @@ -146,7 +154,11 @@ PP(pp_regcomp) if (pm->op_pmdynflags & PMdf_UTF8) t = (char*)bytes_to_utf8((U8*)t, &len); } - PM_SETRE(pm, CALLREGCOMP(aTHX_ (char *)t, (char *)t + len, pm)); + if (eng) + PM_SETRE(pm, CALLREGCOMP_ENG(eng,(char *)t, (char *)t + len, pm)); + else + PM_SETRE(pm, CALLREGCOMP((char *)t, (char *)t + len, pm)); + if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8)) Safefree(t); PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed @@ -197,7 +209,7 @@ PP(pp_substcont) if(old != rx) { if(old) ReREFCNT_dec(old); - PM_SETRE(pm,rx); + PM_SETRE(pm,ReREFCNT_inc(rx)); } rxres_restore(&cx->sb_rxres, rx); @@ -214,7 +226,7 @@ PP(pp_substcont) FREETMPS; /* Prevent excess tmp stack */ /* Are we done */ - if (cx->sb_once || !CALLREGEXEC(aTHX_ rx, s, cx->sb_strend, orig, + if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, s == m, cx->sb_targ, NULL, ((cx->sb_rflags & REXEC_COPY_STR) ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST) @@ -245,7 +257,6 @@ PP(pp_substcont) if (DO_UTF8(dstr)) SvUTF8_on(targ); SvPV_set(dstr, NULL); - sv_free(dstr); TAINT_IF(cx->sb_rxtainted & 1); PUSHs(sv_2mortal(newSViv(saviters - 1))); @@ -256,7 +267,6 @@ PP(pp_substcont) SvTAINT(targ); LEAVE_SCOPE(cx->sb_oldsave); - ReREFCNT_dec(rx); POPSUBST(cx); RETURNOP(pm->op_next); } @@ -285,7 +295,7 @@ PP(pp_substcont) SvUPGRADE(sv, SVt_PVMG); if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) { #ifdef PERL_OLD_COPY_ON_WRITE - if (SvIsCOW(lsv)) + if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); #endif mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob, @@ -798,17 +808,23 @@ PP(pp_formline) case FF_0DECIMAL: arg = *fpc++; #if defined(USE_LONG_DOUBLE) - fmt = (arg & 256) ? "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl; + fmt = (const char *) + ((arg & 256) ? + "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl); #else - fmt = (arg & 256) ? "%#0*.*f" : "%0*.*f"; + fmt = (const char *) + ((arg & 256) ? + "%#0*.*f" : "%0*.*f"); #endif goto ff_dec; case FF_DECIMAL: arg = *fpc++; #if defined(USE_LONG_DOUBLE) - fmt = (arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl; + fmt = (const char *) + ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl); #else - fmt = (arg & 256) ? "%#*.*f" : "%*.*f"; + fmt = (const char *) + ((arg & 256) ? "%#*.*f" : "%*.*f"); #endif ff_dec: /* If the field is marked with ^ and the value is undefined, @@ -831,7 +847,7 @@ PP(pp_formline) /* Formats aren't yet marked for locales, so assume "yes". */ { STORE_NUMERIC_STANDARD_SET_LOCAL(); - sprintf(t, fmt, (int) fieldsize, (int) arg & 255, value); + my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value); RESTORE_NUMERIC_STANDARD(); } t += fieldsize; @@ -1450,7 +1466,7 @@ Perl_qerror(pTHX_ SV *err) else if (PL_errors) sv_catsv(PL_errors, err); else - Perl_warn(aTHX_ "%"SVf, err); + Perl_warn(aTHX_ "%"SVf, (void*)err); ++PL_error_count; } @@ -1511,7 +1527,7 @@ Perl_die_where(pTHX_ const char *message, STRLEN msglen) if (CxTYPE(cx) != CXt_EVAL) { if (!message) message = SvPVx_const(ERRSV, msglen); - PerlIO_write(Perl_error_log, "panic: die ", 11); + PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11); PerlIO_write(Perl_error_log, message, msglen); my_exit(1); } @@ -1721,10 +1737,10 @@ PP(pp_caller) PUSHs(sv_2mortal(mask)); } - PUSHs(cx->blk_oldcop->cop_hints ? + PUSHs(cx->blk_oldcop->cop_hints_hash ? sv_2mortal(newRV_noinc( - (SV*)Perl_refcounted_he_chain_2hv(aTHX_ - cx->blk_oldcop->cop_hints))) + (SV*)Perl_refcounted_he_chain_2hv(aTHX_ + cx->blk_oldcop->cop_hints_hash))) : &PL_sv_undef); RETURN; } @@ -1733,7 +1749,7 @@ PP(pp_reset) { dVAR; dSP; - const char * const tmps = (MAXARG < 1) ? "" : POPpconstx; + const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx; sv_reset(tmps, CopSTASH(PL_curcop)); PUSHs(&PL_sv_yes); RETURN; @@ -1804,7 +1820,7 @@ PP(pp_enteriter) register PERL_CONTEXT *cx; const I32 gimme = GIMME_V; SV **svp; - U32 cxtype = CXt_LOOP | CXp_FOREACH; + U16 cxtype = CXt_LOOP | CXp_FOREACH; #ifdef USE_ITHREADS void *iterdata; #endif @@ -1925,7 +1941,7 @@ PP(pp_leaveloop) TAINT_NOT; if (gimme == G_VOID) - /*EMPTY*/; /* do nothing */ + NOOP; else if (gimme == G_SCALAR) { if (mark < SP) *++newsp = sv_mortalcopy(*SP); @@ -2012,7 +2028,7 @@ PP(pp_return) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - DIE(aTHX_ "%"SVf" did not return a true value", nsv); + DIE(aTHX_ "%"SVf" did not return a true value", (void*)nsv); } break; case CXt_FORMAT: @@ -2109,7 +2125,7 @@ PP(pp_last) case CXt_LOOP: pop2 = CXt_LOOP; newsp = PL_stack_base + cx->blk_loop.resetsp; - nextop = cx->blk_loop.last_op->op_next; + nextop = cx->blk_loop.my_op->op_lastop->op_next; break; case CXt_SUB: pop2 = CXt_SUB; @@ -2192,7 +2208,7 @@ PP(pp_next) if (PL_scopestack_ix < inner) leave_scope(PL_scopestack[PL_scopestack_ix]); PL_curcop = cx->blk_oldcop; - return cx->blk_loop.next_op; + return CX_LOOP_NEXTOP_GET(cx); } PP(pp_redo) @@ -2216,7 +2232,7 @@ PP(pp_redo) if (cxix < cxstack_ix) dounwind(cxix); - redo_op = cxstack[cxix].blk_loop.redo_op; + redo_op = cxstack[cxix].blk_loop.my_op->op_redoop; if (redo_op->op_type == OP_ENTER) { /* pop one less context to avoid $x being freed in while (my $x..) */ cxstack_ix++; @@ -2320,7 +2336,7 @@ PP(pp_goto) goto retry; tmpstr = sv_newmortal(); gv_efullname3(tmpstr, gv, NULL); - DIE(aTHX_ "Goto undefined subroutine &%"SVf"",tmpstr); + DIE(aTHX_ "Goto undefined subroutine &%"SVf"",(void*)tmpstr); } DIE(aTHX_ "Goto undefined subroutine"); } @@ -2413,7 +2429,7 @@ PP(pp_goto) CvDEPTH(cv)++; if (CvDEPTH(cv) < 2) - SvREFCNT_inc_void_NN(cv); + SvREFCNT_inc_simple_void_NN(cv); else { if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); @@ -2434,13 +2450,13 @@ PP(pp_goto) SV **ary = AvALLOC(av); if (AvARRAY(av) != ary) { AvMAX(av) += AvARRAY(av) - AvALLOC(av); - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } if (items >= AvMAX(av) + 1) { AvMAX(av) = items - 1; Renew(ary,items+1,SV*); AvALLOC(av) = ary; - SvPV_set(av, (char*)ary); + AvARRAY(av) = ary; } } ++mark; @@ -2769,8 +2785,8 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp) len = SvCUR(sv); } else - len = my_sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, - (unsigned long)++PL_evalseq); + len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code, + (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -2898,6 +2914,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) /* set up a scratch pad */ CvPADLIST(PL_compcv) = pad_new(padnew_SAVE); + PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */ if (!PL_madskills) @@ -2909,9 +2926,13 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) SAVESPTR(PL_curstash); PL_curstash = CopSTASH(PL_curcop); } + /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */ SAVESPTR(PL_beginav); PL_beginav = newAV(); SAVEFREESV(PL_beginav); + SAVESPTR(PL_unitcheckav); + PL_unitcheckav = newAV(); + SAVEFREESV(PL_unitcheckav); SAVEI32(PL_error_count); #ifdef PERL_MAD @@ -2994,7 +3015,7 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) DEBUG_x(dump_eval()); /* Register with debugger: */ - if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) { + if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) { CV * const cv = get_cv("DB::postponed", FALSE); if (cv) { dSP; @@ -3005,6 +3026,9 @@ S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq) } } + if (PL_unitcheckav) + call_list(PL_scopestack_ix, PL_unitcheckav); + /* compiled okay, so do it */ CvDEPTH(PL_compcv) = 1; @@ -3020,6 +3044,7 @@ S_check_type_and_open(pTHX_ const char *name, const char *mode) { Stat_t st; const int st_rc = PerlLIO_stat(name, &st); + if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) { return NULL; } @@ -3067,6 +3092,7 @@ PP(pp_require) const I32 gimme = GIMME_V; int filter_has_file = 0; PerlIO *tryrsfp = NULL; + SV *filter_cache = NULL; SV *filter_state = NULL; SV *filter_sub = NULL; SV *hook_sv = NULL; @@ -3083,14 +3109,14 @@ PP(pp_require) if (!sv_derived_from(PL_patchlevel, "version")) upg_version(PL_patchlevel); if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) { - if ( vcmp(sv,PL_patchlevel) < 0 ) + if ( vcmp(sv,PL_patchlevel) <= 0 ) DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped", - vnormal(sv), vnormal(PL_patchlevel)); + (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); } else { if ( vcmp(sv,PL_patchlevel) > 0 ) DIE(aTHX_ "Perl %"SVf" required--this is only %"SVf", stopped", - vnormal(sv), vnormal(PL_patchlevel)); + (void*)vnormal(sv), (void*)vnormal(PL_patchlevel)); } RETPUSHYES; @@ -3136,10 +3162,11 @@ PP(pp_require) { namesv = newSV(0); for (i = 0; i <= AvFILL(ar); i++) { - SV *dirsv = *av_fetch(ar, i, TRUE); + SV * const dirsv = *av_fetch(ar, i, TRUE); if (SvROK(dirsv)) { int count; + SV **svp; SV *loader = dirsv; if (SvTYPE(SvRV(loader)) == SVt_PVAV @@ -3167,6 +3194,11 @@ PP(pp_require) count = call_sv(loader, G_ARRAY); SPAGAIN; + /* Adjust file name if the hook has set an %INC entry */ + svp = hv_fetch(GvHVn(PL_incgv), name, len, 0); + if (svp) + tryname = SvPVX_const(*svp); + if (count > 0) { int i = 0; SV *arg; @@ -3174,12 +3206,22 @@ PP(pp_require) SP -= count - 1; arg = SP[i++]; + if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV) + && !isGV_with_GP(SvRV(arg))) { + filter_cache = SvRV(arg); + SvREFCNT_inc_simple_void_NN(filter_cache); + + if (i < count) { + arg = SP[i++]; + } + } + if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) { arg = SvRV(arg); } if (SvTYPE(arg) == SVt_PVGV) { - IO *io = GvIO((GV *)arg); + IO * const io = GvIO((GV *)arg); ++filter_has_file; @@ -3199,17 +3241,17 @@ PP(pp_require) if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) { filter_sub = arg; - SvREFCNT_inc_void_NN(filter_sub); + SvREFCNT_inc_simple_void_NN(filter_sub); if (i < count) { filter_state = SP[i]; SvREFCNT_inc_simple_void(filter_state); } + } - if (!tryrsfp) { - tryrsfp = PerlIO_open(BIT_BUCKET, - PERL_SCRIPT_MODE); - } + if (!tryrsfp && (filter_cache || filter_sub)) { + tryrsfp = PerlIO_open(BIT_BUCKET, + PERL_SCRIPT_MODE); } SP--; } @@ -3224,6 +3266,10 @@ PP(pp_require) } filter_has_file = 0; + if (filter_cache) { + SvREFCNT_dec(filter_cache); + filter_cache = NULL; + } if (filter_state) { SvREFCNT_dec(filter_state); filter_state = NULL; @@ -3282,6 +3328,9 @@ PP(pp_require) tryname += 2; break; } + else if (errno == EMFILE) + /* no point in trying other paths if out of handles */ + break; } } } @@ -3358,14 +3407,13 @@ PP(pp_require) } else PL_compiling.cop_warnings = pWARN_STD ; - SAVESPTR(PL_compiling.cop_io); - PL_compiling.cop_io = NULL; - if (filter_sub) { + if (filter_sub || filter_cache) { SV * const datasv = filter_add(S_run_user_filter, NULL); IoLINES(datasv) = filter_has_file; IoTOP_GV(datasv) = (GV *)filter_state; IoBOTTOM_GV(datasv) = (GV *)filter_sub; + IoFMT_GV(datasv) = (GV *)filter_cache; } /* switch to eval mode */ @@ -3405,14 +3453,14 @@ PP(pp_entereval) CV* runcv; U32 seq; HV *saved_hh = NULL; + const char * const fakestr = "_<(eval )"; + const int fakelen = 9 + 1; if (PL_op->op_private & OPpEVAL_HAS_HH) { saved_hh = (HV*) SvREFCNT_inc(POPs); } sv = POPs; - if (!SvPV_nolen_const(sv)) - RETPUSHUNDEF; TAINT_PROPER("eval"); ENTER; @@ -3430,7 +3478,7 @@ PP(pp_entereval) len = SvCUR(temp_sv); } else - len = my_sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq); + len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq); SAVECOPFILE_FREE(&PL_compiling); CopFILE_set(&PL_compiling, tmpbuf+2); SAVECOPLINE(&PL_compiling); @@ -3448,20 +3496,13 @@ PP(pp_entereval) GvHV(PL_hintgv) = saved_hh; SAVECOMPILEWARNINGS(); PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); - SAVESPTR(PL_compiling.cop_io); - if (specialCopIO(PL_curcop->cop_io)) - PL_compiling.cop_io = PL_curcop->cop_io; - else { - PL_compiling.cop_io = newSVsv(PL_curcop->cop_io); - SAVEFREESV(PL_compiling.cop_io); - } - if (PL_compiling.cop_hints) { - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints); + if (PL_compiling.cop_hints_hash) { + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); } - PL_compiling.cop_hints = PL_curcop->cop_hints; - if (PL_compiling.cop_hints) { + PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash; + if (PL_compiling.cop_hints_hash) { HINTS_REFCNT_LOCK; - PL_compiling.cop_hints->refcounted_he_refcnt++; + PL_compiling.cop_hints_hash->refcounted_he_refcnt++; HINTS_REFCNT_UNLOCK; } /* special case: an eval '' executed within the DB package gets lexically @@ -3483,7 +3524,8 @@ PP(pp_entereval) ret = doeval(gimme, NULL, runcv, seq); if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */ && ret != PL_op->op_next) { /* Successive compilation. */ - strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ + /* Copy in anything fake and short. */ + my_strlcpy(safestr, fakestr, fakelen); } return DOCATCH(ret); } @@ -3544,7 +3586,7 @@ PP(pp_leaveeval) /* Unassume the success we assumed earlier. */ SV * const nsv = cx->blk_eval.old_namesv; (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD); - retop = Perl_die(aTHX_ "%"SVf" did not return a true value", nsv); + retop = Perl_die(aTHX_ "%"SVf" did not return a true value", (void*)nsv); /* die_where() did LEAVE, or we won't be here */ } else { @@ -3605,7 +3647,7 @@ Perl_create_eval_scope(pTHX_ U32 flags) PP(pp_entertry) { dVAR; - PERL_CONTEXT *cx = create_eval_scope(0); + PERL_CONTEXT * const cx = create_eval_scope(0); cx->blk_eval.retop = cLOGOP->op_other->op_next; return DOCATCH(PL_op->op_next); } @@ -3749,42 +3791,8 @@ PP(pp_smartmatch) return do_smartmatch(NULL, NULL); } -/* This version of do_smartmatch() implements the following - table of smart matches: - - $a $b Type of Match Implied Matching Code - ====== ===== ===================== ============= - (overloading trumps everything) - - Code[+] Code[+] referential equality match if refaddr($a) == refaddr($b) - Any Code[+] scalar sub truth match if $b->($a) - - Hash Hash hash keys identical match if sort(keys(%$a)) ÈeqÇ sort(keys(%$b)) - Hash Array hash value slice truth match if $a->{any(@$b)} - Hash Regex hash key grep match if any(keys(%$a)) =~ /$b/ - Hash Any hash entry existence match if exists $a->{$b} - - Array Array arrays are identical[*] match if $a È~~Ç $b - Array Regex array grep match if any(@$a) =~ /$b/ - Array Num array contains number match if any($a) == $b - Array Any array contains string match if any($a) eq $b - - Any undef undefined match if !defined $a - Any Regex pattern match match if $a =~ /$b/ - Code() Code() results are equal match if $a->() eq $b->() - Any Code() simple closure truth match if $b->() (ignoring $a) - Num numish[!] numeric equality match if $a == $b - Any Str string equality match if $a eq $b - Any Num numeric equality match if $a == $b - - Any Any string equality match if $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) - * - if a circular reference is found, we fall back to referential equality - ! - either a real number, or a string that looks_like_number() - +/* This version of do_smartmatch() implements the + * table of smart matches that is found in perlsyn. */ STATIC OP * @@ -3795,39 +3803,39 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SV *e = TOPs; /* e is for 'expression' */ SV *d = TOPm1s; /* d is for 'default', as in PL_defgv */ - SV *this, *other; + 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))) + (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))) + ((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)) \ + (SvROK(d) && SvMAGICAL(This = SvRV(d)) \ + && (mg = mg_find(This, PERL_MAGIC_qr)) \ && (this_regex = (regexp *)mg->mg_obj) \ - && (other = e)) \ + && (Other = e)) \ || \ - (SvROK(e) && SvMAGICAL(this = SvRV(e)) \ - && (mg = mg_find(this, PERL_MAGIC_qr)) \ + (SvROK(e) && SvMAGICAL(This = SvRV(e)) \ + && (mg = mg_find(This, PERL_MAGIC_qr)) \ && (this_regex = (regexp *)mg->mg_obj) \ - && (other = d)) ) + && (Other = d)) ) # define SM_OTHER_REF(type) \ - (SvROK(other) && SvTYPE(SvRV(other)) == SVt_##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)) \ +# define SM_OTHER_REGEX (SvROK(Other) && SvMAGICAL(SvRV(Other)) \ + && (mg = mg_find(SvRV(Other), PERL_MAGIC_qr)) \ && (other_regex = (regexp *)mg->mg_obj)) @@ -3857,9 +3865,9 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SM_CV_NEP) { I32 c; - if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(other)) ) + if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) ) { - if (this == SvRV(other)) + if (This == SvRV(Other)) RETPUSHYES; else RETPUSHNO; @@ -3868,14 +3876,14 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) ENTER; SAVETMPS; PUSHMARK(SP); - PUSHs(other); + PUSHs(Other); PUTBACK; - c = call_sv(this, G_SCALAR); + c = call_sv(This, G_SCALAR); SPAGAIN; if (c == 0) PUSHs(&PL_sv_no); else if (SvTEMP(TOPs)) - SvREFCNT_inc(TOPs); + SvREFCNT_inc_void(TOPs); FREETMPS; LEAVE; RETURN; @@ -3884,39 +3892,39 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) if (SM_OTHER_REF(PVHV)) { /* Check that the key-sets are identical */ HE *he; - HV *other_hv = (HV *) SvRV(other); + HV *other_hv = (HV *) SvRV(Other); bool tied = FALSE; bool other_tied = FALSE; U32 this_key_count = 0, other_key_count = 0; /* Tied hashes don't know how many keys they have. */ - if (SvTIED_mg(this, PERL_MAGIC_tied)) { + if (SvTIED_mg(This, PERL_MAGIC_tied)) { tied = TRUE; } else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) { HV * const temp = other_hv; - other_hv = (HV *) this; - this = (SV *) temp; + other_hv = (HV *) This; + This = (SV *) temp; tied = TRUE; } if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) other_tied = TRUE; - if (!tied && HvUSEDKEYS((HV *) this) != HvUSEDKEYS(other_hv)) + if (!tied && HvUSEDKEYS((HV *) This) != 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((HV *) this); - while ( (he = hv_iternext((HV *) this)) ) { + (void) hv_iterinit((HV *) This); + while ( (he = hv_iternext((HV *) This)) ) { 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((HV *) this); /* reset iterator */ + (void) hv_iterinit((HV *) This); /* reset iterator */ RETPUSHNO; } } @@ -3935,11 +3943,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHYES; } else if (SM_OTHER_REF(PVAV)) { - AV * const other_av = (AV *) SvRV(other); + AV * const other_av = (AV *) SvRV(Other); const I32 other_len = av_len(other_av) + 1; I32 i; - if (HvUSEDKEYS((HV *) this) != other_len) + if (HvUSEDKEYS((HV *) This) != other_len) RETPUSHNO; for(i = 0; i < other_len; ++i) { @@ -3951,7 +3959,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; key = SvPV(*svp, key_len); - if(!hv_exists((HV *) this, key, key_len)) + if(!hv_exists((HV *) This, key, key_len)) RETPUSHNO; } RETPUSHYES; @@ -3960,10 +3968,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PMOP * const matcher = make_matcher(other_regex); HE *he; - (void) hv_iterinit((HV *) this); - while ( (he = hv_iternext((HV *) this)) ) { + (void) hv_iterinit((HV *) This); + while ( (he = hv_iternext((HV *) This)) ) { if (matcher_matches_sv(matcher, hv_iterkeysv(he))) { - (void) hv_iterinit((HV *) this); + (void) hv_iterinit((HV *) This); destroy_matcher(matcher); RETPUSHYES; } @@ -3972,7 +3980,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) RETPUSHNO; } else { - if (hv_exists_ent((HV *) this, other, 0)) + if (hv_exists_ent((HV *) This, Other, 0)) RETPUSHYES; else RETPUSHNO; @@ -3980,8 +3988,8 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else if (SM_REF(PVAV)) { if (SM_OTHER_REF(PVAV)) { - AV *other_av = (AV *) SvRV(other); - if (av_len((AV *) this) != av_len(other_av)) + AV *other_av = (AV *) SvRV(Other); + if (av_len((AV *) This) != av_len(other_av)) RETPUSHNO; else { I32 i; @@ -3996,7 +4004,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) (void) sv_2mortal((SV *) seen_other); } for(i = 0; i <= other_len; ++i) { - SV * const * const this_elem = av_fetch((AV *)this, i, FALSE); + SV * const * const this_elem = av_fetch((AV *)This, i, FALSE); SV * const * const other_elem = av_fetch(other_av, i, FALSE); if (!this_elem || !other_elem) { @@ -4032,11 +4040,11 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } else if (SM_OTHER_REGEX) { PMOP * const matcher = make_matcher(other_regex); - const I32 this_len = av_len((AV *) this); + const I32 this_len = av_len((AV *) This); I32 i; for(i = 0; i <= this_len; ++i) { - SV * const * const svp = av_fetch((AV *)this, i, FALSE); + SV * const * const svp = av_fetch((AV *)This, i, FALSE); if (svp && matcher_matches_sv(matcher, *svp)) { destroy_matcher(matcher); RETPUSHYES; @@ -4045,15 +4053,15 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) destroy_matcher(matcher); RETPUSHNO; } - else if (SvIOK(other) || SvNOK(other)) { + else if (SvIOK(Other) || SvNOK(Other)) { I32 i; - for(i = 0; i <= AvFILL((AV *) this); ++i) { - SV * const * const svp = av_fetch((AV *)this, i, FALSE); + for(i = 0; i <= AvFILL((AV *) This); ++i) { + SV * const * const svp = av_fetch((AV *)This, i, FALSE); if (!svp) continue; - PUSHs(other); + PUSHs(Other); PUSHs(*svp); PUTBACK; if (CopHINTS_get(PL_curcop) & HINT_INTEGER) @@ -4066,16 +4074,16 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) } RETPUSHNO; } - else if (SvPOK(other)) { - const I32 this_len = av_len((AV *) this); + else if (SvPOK(Other)) { + const I32 this_len = av_len((AV *) This); I32 i; for(i = 0; i <= this_len; ++i) { - SV * const * const svp = av_fetch((AV *)this, i, FALSE); + SV * const * const svp = av_fetch((AV *)This, i, FALSE); if (!svp) continue; - PUSHs(other); + PUSHs(Other); PUSHs(*svp); PUTBACK; (void) pp_seq(); @@ -4096,7 +4104,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) PMOP * const matcher = make_matcher(this_regex); PUTBACK; - PUSHs(matcher_matches_sv(matcher, other) + PUSHs(matcher_matches_sv(matcher, Other) ? &PL_sv_yes : &PL_sv_no); destroy_matcher(matcher); @@ -4111,23 +4119,23 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) SAVETMPS; PUSHMARK(SP); PUTBACK; - c = call_sv(this, G_SCALAR); + c = call_sv(This, G_SCALAR); SPAGAIN; if (c == 0) PUSHs(&PL_sv_undef); else if (SvTEMP(TOPs)) - SvREFCNT_inc(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); + c = call_sv(SvRV(Other), G_SCALAR); SPAGAIN; if (c == 0) PUSHs(&PL_sv_undef); else if (SvTEMP(TOPs)) - SvREFCNT_inc(TOPs); + SvREFCNT_inc_void(TOPs); FREETMPS; LEAVE; PUTBACK; @@ -4138,10 +4146,10 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other) LEAVE; RETURN; } - else if ( ((SvIOK(d) || SvNOK(d)) && (this = d) && (other = e)) - || ((SvIOK(e) || SvNOK(e)) && (this = e) && (other = d)) ) + 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)) { + if (SvPOK(Other) && !looks_like_number(Other)) { /* String comparison */ PUSHs(d); PUSHs(e); PUTBACK; @@ -4260,7 +4268,7 @@ PP(pp_break) PL_curcop = cx->blk_oldcop; if (CxFOREACH(cx)) - return cx->blk_loop.next_op; + return CX_LOOP_NEXTOP_GET(cx); else return cx->blk_givwhen.leave_op; } @@ -4519,19 +4527,16 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SV * const filter_state = (SV *)IoTOP_GV(datasv); SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv); int status = 0; - /* Filter API says that the filter appends to the contents of the buffer. - Usually the buffer is "", so the details don't matter. But if it's not, - then clearly what it contains is already filtered by this filter, so we - don't want to pass it in a second time. - I'm going to use a mortal in case the upstream filter croaks. */ - SV *const upstream - = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) - ? sv_newmortal() : buf_sv; + SV *upstream; STRLEN got_len; - const char *got_p; + const char *got_p = NULL; const char *prune_from = NULL; + bool read_from_cache = FALSE; + STRLEN umaxlen; + + assert(maxlen >= 0); + umaxlen = maxlen; - SvUPGRADE(upstream, SVt_PV); /* I was having segfault trouble under Linux 2.2.5 after a parse error occured. (Had to hack around it with a test for PL_error_count == 0.) Solaris doesn't segfault -- @@ -4544,16 +4549,17 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) const char *cache_p = SvPV(cache, cache_len); STRLEN take = 0; - if (maxlen) { + if (umaxlen) { /* Running in block mode and we have some cached data already. */ - if (cache_len >= maxlen) { + if (cache_len >= umaxlen) { /* In fact, so much data we don't even need to call filter_read. */ - take = maxlen; + take = umaxlen; } } else { - const char *const first_nl = memchr(cache_p, '\n', cache_len); + const char *const first_nl = + (const char *)memchr(cache_p, '\n', cache_len); if (first_nl) { take = first_nl + 1 - cache_p; } @@ -4566,15 +4572,25 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) } sv_catsv(buf_sv, cache); - if (maxlen) { - maxlen -= cache_len; + if (umaxlen) { + umaxlen -= cache_len; } SvOK_off(cache); + read_from_cache = TRUE; } } + + /* Filter API says that the filter appends to the contents of the buffer. + Usually the buffer is "", so the details don't matter. But if it's not, + then clearly what it contains is already filtered by this filter, so we + don't want to pass it in a second time. + I'm going to use a mortal in case the upstream filter croaks. */ + upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv)) + ? sv_newmortal() : buf_sv; + SvUPGRADE(upstream, SVt_PV); if (filter_has_file) { - status = FILTER_READ(idx+1, upstream, maxlen); + status = FILTER_READ(idx+1, upstream, 0); } if (filter_sub && status >= 0) { @@ -4588,7 +4604,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) DEFSV = upstream; PUSHMARK(SP); - PUSHs(sv_2mortal(newSViv(maxlen))); + PUSHs(sv_2mortal(newSViv(0))); if (filter_state) { PUSHs(filter_state); } @@ -4610,12 +4626,13 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) if(SvOK(upstream)) { got_p = SvPV(upstream, got_len); - if (maxlen) { - if (got_len > maxlen) { - prune_from = got_p + maxlen; + if (umaxlen) { + if (got_len > umaxlen) { + prune_from = got_p + umaxlen; } } else { - const char *const first_nl = memchr(got_p, '\n', got_len); + const char *const first_nl = + (const char *)memchr(got_p, '\n', got_len); if (first_nl && first_nl + 1 < got_p + got_len) { /* There's a second line here... */ prune_from = first_nl + 1; @@ -4628,7 +4645,7 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) SV *cache = (SV *)IoFMT_GV(datasv); if (!cache) { - IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - maxlen)); + IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen)); } else if (SvOK(cache)) { /* Cache should be empty. */ assert(!SvCUR(cache)); @@ -4648,7 +4665,11 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) status = 1; } - if (upstream != buf_sv) { + /* If they are at EOF but buf_sv has something in it, then they may never + have touched the SV upstream, so it may be undefined. If we naively + concatenate it then we get a warning about use of uninitialised value. + */ + if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) { sv_catsv(buf_sv, upstream); } @@ -4665,6 +4686,12 @@ S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen) } filter_del(S_run_user_filter); } + if (status == 0 && read_from_cache) { + /* If we read some data from the cache (and by getting here it implies + that we emptied the cache) then we aren't yet at EOF, and mustn't + report that to our caller. */ + return 1; + } return status; }