X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=58ab34ccda41c9af62f77ca9cb2f0e0734c4d848;hb=9f8d30d514938e706a878aae5fd5b902550604e2;hp=6d6b4695565b1953de1487e87370cc1d668434f2;hpb=55497cffdd24c959994f9a8ddd56db8ce85e1c5b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 6d6b469..58ab34c 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -31,8 +31,9 @@ static I32 dopoptolabel _((char *label)); static I32 dopoptoloop _((I32 startingblock)); static I32 dopoptosub _((I32 startingblock)); static void save_lines _((AV *array, SV *sv)); -static int sortcmp _((const void *, const void *)); static int sortcv _((const void *, const void *)); +static int sortcmp _((const void *, const void *)); +static int sortcmp_locale _((const void *, const void *)); static I32 sortcxix; @@ -108,6 +109,8 @@ PP(pp_substcont) if (cx->sb_iters > cx->sb_maxiters) DIE("Substitution loop"); + if (!cx->sb_rxtainted) + cx->sb_rxtainted = SvTAINTED(TOPs); sv_catsv(dstr, POPs); if (rx->subbase) Safefree(rx->subbase); @@ -130,6 +133,8 @@ PP(pp_substcont) (void)SvPOK_only(targ); SvSETMAGIC(targ); + if (cx->sb_rxtainted) + SvTAINTED_on(targ); PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1))); LEAVE_SCOPE(cx->sb_oldsave); POPSUBST(cx); @@ -147,6 +152,7 @@ PP(pp_substcont) sv_catpvn(dstr, s, m-s); cx->sb_s = rx->endp[0]; cx->sb_subbase = rx->subbase; + cx->sb_rxtainted |= rx->exec_tainted; rx->subbase = Nullch; /* so recursion works */ RETURNOP(pm->op_pmreplstart); @@ -376,6 +382,8 @@ PP(pp_formline) } gotsome = TRUE; value = SvNV(sv); + /* Formats aren't yet marked for locales, so assume "yes". */ + SET_NUMERIC_LOCAL(); if (arg & 256) { sprintf(t, "%#*.*f", (int) fieldsize, (int) arg & 255, value); } else { @@ -604,10 +612,9 @@ PP(pp_sort) while (MARK < SP) { /* This may or may not shift down one here. */ /*SUPPRESS 560*/ if (*up = *++MARK) { /* Weed out nulls. */ - if (!SvPOK(*up)) + SvTEMP_off(*up); + if (!sortcop && !SvPOK(*up)) (void)sv_2pv(*up, &na); - else - SvTEMP_off(*up); up++; } } @@ -649,7 +656,8 @@ PP(pp_sort) else { if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ - qsort((char*)(ORIGMARK+1), max, sizeof(SV*), sortcmp); + qsort((char*)(ORIGMARK+1), max, sizeof(SV*), + (op->op_private & OPpLOCALE) ? sortcmp_locale : sortcmp); } } stack_sp = ORIGMARK + max; @@ -707,18 +715,16 @@ PP(pp_flop) I32 max; if (SvNIOKp(left) || !SvPOKp(left) || - (looks_like_number(left) && *SvPVX(left) != '0') ) { - SV *sv_iv; - + (looks_like_number(left) && *SvPVX(left) != '0') ) + { i = SvIV(left); max = SvIV(right); - if (max > i) + if (max >= i) { + EXTEND_MORTAL(max - i + 1); EXTEND(SP, max - i + 1); - sv_iv = sv_2mortal(newSViv(i)); - if (i++ <= max) PUSHs(sv_iv); + } while (i <= max) { - sv = sv_mortalcopy(sv_iv); - sv_setiv(sv,i++); + sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } } @@ -857,7 +863,7 @@ I32 startingblock; switch (cx->cx_type) { case CXt_SUBST: if (dowarn) - warn("Exiting substitition via %s", op_name[op->op_type]); + warn("Exiting substitution via %s", op_name[op->op_type]); break; case CXt_SUB: if (dowarn) @@ -904,54 +910,6 @@ I32 cxix; } } -#ifdef I_STDARG -OP * -die(char* pat, ...) -#else -/*VARARGS0*/ -OP * -die(pat, va_alist) - char *pat; - va_dcl -#endif -{ - va_list args; - char *message; - int oldrunlevel = runlevel; - int was_in_eval = in_eval; - HV *stash; - GV *gv; - CV *cv; - - /* We have to switch back to mainstack or die_where may try to pop - * the eval block from the wrong stack if die is being called from a - * signal handler. - dkindred@cs.cmu.edu */ - if (curstack != mainstack) { - dSP; - SWITCHSTACK(curstack, mainstack); - } -#ifdef I_STDARG - va_start(args, pat); -#else - va_start(args); -#endif - message = mess(pat, &args); - va_end(args); - if (diehook && (cv = sv_2cv(diehook, &stash, &gv, 0)) && !CvDEPTH(cv)) { - dSP; - - PUSHMARK(sp); - EXTEND(sp, 1); - PUSHs(sv_2mortal(newSVpv(message,0))); - PUTBACK; - perl_call_sv((SV*)cv, G_DISCARD); - } - restartop = die_where(message); - if ((!restartop && was_in_eval) || oldrunlevel > 1) - Siglongjmp(top_env, 3); - return restartop; -} - OP * die_where(message) char *message; @@ -1193,63 +1151,15 @@ sortcmp(a, b) const void *a; const void *b; { - register SV *str1 = *(SV **) a; - register SV *str2 = *(SV **) b; - I32 retval; - - if (!SvPOKp(str1)) { - if (!SvPOKp(str2)) - return 0; - else - return -1; - } - if (!SvPOKp(str2)) - return 1; - - if (lc_collate_active) { /* NOTE: this is the LC_COLLATE branch */ - register char * pv1, * pv2, * pvx; - STRLEN cur1, cur2, curx; - - pv1 = SvPV(str1, cur1); - pvx = mem_collxfrm(pv1, cur1, &curx); - pv1 = pvx; - cur1 = curx; - - pv2 = SvPV(str2, cur2); - pvx = mem_collxfrm(pv2, cur2, &curx); - pv2 = pvx; - cur2 = curx; - - retval = memcmp((void *)pv1, (void *)pv2, cur1 < cur2 ? cur1 : cur2); - - Safefree(pv1); - Safefree(pv2); - - if (retval) - return retval < 0 ? -1 : 1; - - if (cur1 == cur2) - return 0; - else - return cur1 < cur2 ? -1 : 1; - } - - /* NOTE: this is the non-LC_COLLATE area */ + return sv_cmp(*(SV **)a, *(SV **)b); +} - if (SvCUR(str1) < SvCUR(str2)) { - /*SUPPRESS 560*/ - if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str1))) - return retval; - else - return -1; - } - /*SUPPRESS 560*/ - else if (retval = memcmp(SvPVX(str1), SvPVX(str2), SvCUR(str2))) - return retval; - else if (SvCUR(str1) == SvCUR(str2)) - return 0; - else - return 1; +static int +sortcmp_locale(a, b) +const void *a; +const void *b; +{ + return sv_cmp_locale(*(SV **)a, *(SV **)b); } PP(pp_reset) @@ -1343,11 +1253,8 @@ PP(pp_enteriter) PUSHBLOCK(cx, CXt_LOOP, SP); PUSHLOOP(cx, svp, MARK); - if (op->op_flags & OPf_STACKED) { - AV* av = (AV*)POPs; - cx->blk_loop.iterary = av; - cx->blk_loop.iterix = -1; - } + if (op->op_flags & OPf_STACKED) + cx->blk_loop.iterary = (AV*)SvREFCNT_inc(POPs); else { cx->blk_loop.iterary = curstack; AvFILL(curstack) = sp - stack_base; @@ -1679,6 +1586,7 @@ PP(pp_goto) EXTEND(stack_sp, items); /* @_ could have been extended. */ Copy(AvARRAY(av), stack_sp, items, SV*); stack_sp += items; + SvREFCNT_dec(GvAV(defgv)); GvAV(defgv) = cx->blk_sub.savearray; AvREAL_off(av); av_clear(av); @@ -1720,8 +1628,7 @@ PP(pp_goto) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ if (CvDEPTH(cv) == 100 && dowarn) - warn("Deep recursion on subroutine \"%s\"", - GvENAME(CvGV(cv))); + sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *newpad = newAV(); SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]); @@ -1730,8 +1637,10 @@ PP(pp_goto) for ( ;ix > 0; ix--) { if (svp[ix] != &sv_undef) { char *name = SvPVX(svp[ix]); - if (SvFLAGS(svp[ix]) & SVf_FAKE) { - /* outer lexical? */ + if ((SvFLAGS(svp[ix]) & SVf_FAKE) + || *name == '&') + { + /* outer lexical or anon code */ av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]) ); } @@ -1769,7 +1678,7 @@ PP(pp_goto) cx->blk_sub.savearray = GvAV(defgv); cx->blk_sub.argarray = av; - GvAV(defgv) = cx->blk_sub.argarray; + GvAV(defgv) = (AV*)SvREFCNT_inc(av); ++mark; if (items >= AvMAX(av) + 1) { @@ -1795,12 +1704,13 @@ PP(pp_goto) } } if (perldb && curstash != debstash) { - /* &xsub is not copying @_ */ + /* + * We do not care about using sv to call CV; + * it's for informational purposes only. + */ SV *sv = GvSV(DBsub); save_item(sv); gv_efullname3(sv, CvGV(cv), Nullch); - /* We do not care about using sv to call CV, - * just for info. */ } RETURNOP(CvSTART(cv)); } @@ -1992,6 +1902,7 @@ int gimme; dSP; OP *saveop = op; HV *newstash; + CV *caller; AV* comppadlist; in_eval = 1; @@ -2008,9 +1919,11 @@ int gimme; SAVEI32(min_intro_pending); SAVEI32(max_intro_pending); + caller = compcv; SAVESPTR(compcv); compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)compcv, SVt_PVCV); + CvUNIQUE_on(compcv); comppad = newAV(); comppad_name = newAV(); @@ -2025,6 +1938,10 @@ int gimme; av_store(comppadlist, 0, (SV*)comppad_name); av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(compcv) = comppadlist; + + if (saveop->op_type != OP_REQUIRE) + CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller); + SAVEFREESV(compcv); /* make sure we compile in the right package */ @@ -2117,6 +2034,7 @@ PP(pp_require) sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { + SET_NUMERIC_STANDARD(); if (atof(patchlevel) + 0.00000999 < SvNV(sv)) DIE("Perl %s required--this is only version %s, stopped", SvPV(sv,na),patchlevel); @@ -2142,8 +2060,8 @@ PP(pp_require) || (tmpname[0] && tmpname[1] == ':') #endif #ifdef VMS - || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') && - (tmpname[1] == '-' || tmpname[1] == ']' || tmpname[1] == '>'))) + || (strchr(tmpname,':') || ((*tmpname == '[' || *tmpname == '<') && + (isALNUM(tmpname[1]) || strchr("$-_]>",tmpname[1])))) #endif ) { @@ -2152,13 +2070,15 @@ PP(pp_require) else { AV *ar = GvAVn(incgv); I32 i; - - for (i = 0; i <= AvFILL(ar); i++) { #ifdef VMS + char unixified[256]; + if (tounixspec_ts(tmpname,unixified) != NULL) + for (i = 0; i <= AvFILL(ar); i++) { if (tounixpath_ts(SvPVx(*av_fetch(ar, i, TRUE), na),buf) == NULL) continue; - strcat(buf,name); + strcat(buf,unixified); #else + for (i = 0; i <= AvFILL(ar); i++) { (void)sprintf(buf, "%s/%s", SvPVx(*av_fetch(ar, i, TRUE), na), name); #endif @@ -2418,7 +2338,7 @@ SV *sv; bool ischop; if (len == 0) - die("Null picture in formline"); + croak("Null picture in formline"); New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ fpc = fops; @@ -2453,13 +2373,12 @@ SV *sv; skipspaces++; arg -= skipspaces; if (arg) { - if (postspace) { + if (postspace) *fpc++ = FF_SPACE; - postspace = FALSE; - } *fpc++ = FF_LITERAL; *fpc++ = arg; } + postspace = FALSE; if (s <= send) skipspaces--; if (skipspaces) {