X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=58ab34ccda41c9af62f77ca9cb2f0e0734c4d848;hb=9f8d30d514938e706a878aae5fd5b902550604e2;hp=0c7e3d4f038bda99359d8b94d32570c13d1780ea;hpb=e5cf08def37eb3e6aae76e85f2a3156394cae970;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index 0c7e3d4..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); @@ -174,7 +180,7 @@ PP(pp_formline) bool gotsome; STRLEN len; - if (!SvCOMPILED(form)) { + if (!SvMAGICAL(form) || !SvCOMPILED(form)) { SvREADONLY_off(form); doparseform(form); } @@ -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,14 +715,16 @@ PP(pp_flop) I32 max; if (SvNIOKp(left) || !SvPOKp(left) || - (looks_like_number(left) && *SvPVX(left) != '0') ) { + (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); + } while (i <= max) { - sv = sv_mortalcopy(&sv_no); - sv_setiv(sv,i++); + sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } } @@ -853,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) @@ -900,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; @@ -1189,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) @@ -1295,7 +1209,7 @@ PP(pp_dbstate) SAVETMPS; SAVEI32(debug); - SAVESPTR(stack_sp); + SAVESTACK_POS(); debug = 0; hasargs = 0; sp = stack_sp; @@ -1339,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; @@ -1675,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); @@ -1716,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]); @@ -1726,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]) ); } @@ -1765,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) { @@ -1791,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)); } @@ -1988,6 +1902,7 @@ int gimme; dSP; OP *saveop = op; HV *newstash; + CV *caller; AV* comppadlist; in_eval = 1; @@ -1996,17 +1911,19 @@ int gimme; /* set up a scratch pad */ - SAVEINT(padix); + SAVEI32(padix); SAVESPTR(curpad); SAVESPTR(comppad); SAVESPTR(comppad_name); - SAVEINT(comppad_name_fill); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); + SAVEI32(comppad_name_fill); + 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(); @@ -2021,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 */ @@ -2080,6 +2001,20 @@ int gimme; DEBUG_x(dump_eval()); + /* Register with debugger: */ + + if (perldb && saveop->op_type == OP_REQUIRE) { + CV *cv = perl_get_cv("DB::postponed", FALSE); + + if (cv) { + dSP; + PUSHMARK(sp); + XPUSHs((SV*)compiling.cop_filegv); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + } + } + /* compiled okay, so do it */ SP = stack_base + POPMARK; /* pop original mark */ @@ -2099,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); @@ -2124,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 ) { @@ -2134,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 @@ -2213,9 +2151,10 @@ PP(pp_entereval) dSP; register CONTEXT *cx; dPOPss; - I32 gimme = GIMME; - char tmpbuf[32]; + I32 gimme = GIMME, was = sub_generation; + char tmpbuf[32], *safestr; STRLEN len; + OP *ret; if (!SvPV(sv,len) || !len) RETPUSHUNDEF; @@ -2231,7 +2170,13 @@ PP(pp_entereval) sprintf(tmpbuf, "_<(eval %d)", ++evalseq); compiling.cop_filegv = gv_fetchfile(tmpbuf+2); compiling.cop_line = 1; - SAVEDELETE(defstash, savepv(tmpbuf), strlen(tmpbuf)); + /* XXX For Cs within BEGIN {} blocks, this ends up + deleting the eval's FILEGV from the stash before gv_check() runs + (i.e. before run-time proper). To work around the coredump that + ensues, we always turn GvMULTI_on for any globals that were + introduced within evals. See force_ident(). GSAR 96-10-12 */ + safestr = savepv(tmpbuf); + SAVEDELETE(defstash, safestr, strlen(safestr)); SAVEI32(hints); hints = op->op_targ; @@ -2244,7 +2189,11 @@ PP(pp_entereval) if (perldb && curstash != debstash) save_lines(GvAV(compiling.cop_filegv), linestr); PUTBACK; - return doeval(gimme); + ret = doeval(gimme); + if (perldb && was != sub_generation) { /* Some subs defined here. */ + strcpy(safestr, "_<(eval )"); /* Anything fake and short. */ + } + return ret; } PP(pp_leaveeval) @@ -2388,7 +2337,10 @@ SV *sv; register I32 arg; bool ischop; - New(804, fops, (send - s)*3+2, U16); /* Almost certainly too long... */ + if (len == 0) + croak("Null picture in formline"); + + New(804, fops, (send - s)*3+10, U16); /* Almost certainly too long... */ fpc = fops; if (s < send) { @@ -2421,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) { @@ -2543,5 +2494,6 @@ SV *sv; } Copy(fops, s, arg, U16); Safefree(fops); + sv_magic(sv, Nullsv, 'f', Nullch, 0); SvCOMPILED_on(sv); }