X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pp_ctl.c;h=ec9823334a66eca96202bc84ca92f320113f0bd7;hb=eb57363fedc1e70c9a6269b74b72371ac0c5eeef;hp=e488749fe0f3b843f87d0fc4f70302248f1c31d0;hpb=7056ecde998641870cea46de6e48f076abfdde78;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pp_ctl.c b/pp_ctl.c index e488749..ec98233 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1,6 +1,6 @@ /* pp_ctl.c * - * Copyright (c) 1991-1997, Larry Wall + * Copyright (c) 1991-1999, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -41,6 +41,11 @@ static void save_lines _((AV *array, SV *sv)); static I32 sortcv _((SV *a, SV *b)); static void qsortsv _((SV **array, size_t num_elts, I32 (*fun)(SV *a, SV *b))); static OP *doeval _((int gimme, OP** startop)); +static PerlIO *doopen _((const char *name, const char *mode)); +static I32 sv_ncmp _((SV *a, SV *b)); +static I32 sv_i_ncmp _((SV *a, SV *b)); +static I32 amagic_ncmp _((SV *a, SV *b)); +static I32 amagic_i_ncmp _((SV *a, SV *b)); static I32 amagic_cmp _((SV *str1, SV *str2)); static I32 amagic_cmp_locale _((SV *str1, SV *str2)); #endif @@ -164,8 +169,10 @@ PP(pp_substcont) /* Are we done */ if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, - s == m, Nullsv, NULL, - cx->sb_safebase ? 0 : REXEC_COPY_STR)) + s == m, cx->sb_targ, NULL, + ((cx->sb_rflags & REXEC_COPY_STR) + ? REXEC_IGNOREPOS + : (REXEC_COPY_STR|REXEC_IGNOREPOS)))) { SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); @@ -668,12 +675,8 @@ PP(pp_grepstart) ENTER; /* enter outer scope */ SAVETMPS; -#ifdef USE_THREADS - /* SAVE_DEFSV does *not* suffice here */ - save_sptr(&THREADSV(0)); -#else - SAVESPTR(GvSV(PL_defgv)); -#endif /* USE_THREADS */ + /* SAVE_DEFSV does *not* suffice here for USE_THREADS */ + SAVESPTR(DEFSV); ENTER; /* enter inner scope */ SAVESPTR(PL_curpm); @@ -755,6 +758,20 @@ PP(pp_mapwhile) } } +STATIC I32 +sv_ncmp (SV *a, SV *b) +{ + double nv1 = SvNV(a); + double nv2 = SvNV(b); + return nv1 < nv2 ? -1 : nv1 > nv2 ? 1 : 0; +} +STATIC I32 +sv_i_ncmp (SV *a, SV *b) +{ + IV iv1 = SvIV(a); + IV iv2 = SvIV(b); + return iv1 < iv2 ? -1 : iv1 > iv2 ? 1 : 0; +} #define tryCALL_AMAGICbin(left,right,meth,svp) STMT_START { \ *svp = Nullsv; \ if (PL_amagic_generation) { \ @@ -767,6 +784,50 @@ PP(pp_mapwhile) } STMT_END STATIC I32 +amagic_ncmp(register SV *a, register SV *b) +{ + SV *tmpsv; + tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_ncmp(a, b); +} + +STATIC I32 +amagic_i_ncmp(register SV *a, register SV *b) +{ + SV *tmpsv; + tryCALL_AMAGICbin(a,b,ncmp,&tmpsv); + if (tmpsv) { + double d; + + if (SvIOK(tmpsv)) { + I32 i = SvIVX(tmpsv); + if (i > 0) + return 1; + return i? -1 : 0; + } + d = SvNV(tmpsv); + if (d > 0) + return 1; + return d? -1 : 0; + } + return sv_i_ncmp(a, b); +} + +STATIC I32 amagic_cmp(register SV *str1, register SV *str2) { SV *tmpsv; @@ -875,10 +936,11 @@ PP(pp_sort) if (*up = *++MARK) { /* Weed out nulls. */ SvTEMP_off(*up); if (!PL_sortcop && !SvPOK(*up)) { + STRLEN n_a; if (SvAMAGIC(*up)) overloading = 1; else - (void)sv_2pv(*up, &PL_na); + (void)sv_2pv(*up, &n_a); } up++; } @@ -926,13 +988,30 @@ PP(pp_sort) if (max > 1) { MEXTEND(SP, 20); /* Can't afford stack realloc on signal. */ qsortsv(ORIGMARK+1, max, - (PL_op->op_private & OPpLOCALE) - ? ( overloading - ? FUNC_NAME_TO_PTR(amagic_cmp_locale) - : FUNC_NAME_TO_PTR(sv_cmp_locale)) - : ( overloading - ? FUNC_NAME_TO_PTR(amagic_cmp) - : FUNC_NAME_TO_PTR(sv_cmp) )); + (PL_op->op_private & OPpSORT_NUMERIC) + ? ( (PL_op->op_private & OPpSORT_INTEGER) + ? ( overloading + ? FUNC_NAME_TO_PTR(amagic_i_ncmp) + : FUNC_NAME_TO_PTR(sv_i_ncmp)) + : ( overloading + ? FUNC_NAME_TO_PTR(amagic_ncmp) + : FUNC_NAME_TO_PTR(sv_ncmp))) + : ( (PL_op->op_private & OPpLOCALE) + ? ( overloading + ? FUNC_NAME_TO_PTR(amagic_cmp_locale) + : FUNC_NAME_TO_PTR(sv_cmp_locale)) + : ( overloading + ? FUNC_NAME_TO_PTR(amagic_cmp) + : FUNC_NAME_TO_PTR(sv_cmp) ))); + if (PL_op->op_private & OPpSORT_REVERSE) { + SV **p = ORIGMARK+1; + SV **q = ORIGMARK+max; + while (p < q) { + SV *tmp = *p; + *p++ = *q; + *q-- = tmp; + } + } } } LEAVE; @@ -987,33 +1066,41 @@ PP(pp_flop) if (GIMME == G_ARRAY) { dPOPPOPssrl; - register I32 i; + register I32 i, j; register SV *sv; I32 max; + if (SvGMAGICAL(left)) + mg_get(left); + if (SvGMAGICAL(right)) + mg_get(right); + if (SvNIOKp(left) || !SvPOKp(left) || (looks_like_number(left) && *SvPVX(left) != '0') ) { - if (SvNV(left) < IV_MIN || SvNV(right) >= IV_MAX) + if (SvNV(left) < IV_MIN || SvNV(right) > IV_MAX) croak("Range iterator outside integer range"); i = SvIV(left); max = SvIV(right); if (max >= i) { - EXTEND_MORTAL(max - i + 1); - EXTEND(SP, max - i + 1); + j = max - i + 1; + EXTEND_MORTAL(j); + EXTEND(SP, j); } - while (i <= max) { + else + j = 0; + while (j--) { sv = sv_2mortal(newSViv(i++)); PUSHs(sv); } } else { SV *final = sv_mortalcopy(right); - STRLEN len; + STRLEN len, n_a; char *tmps = SvPV(final, len); sv = sv_mortalcopy(left); - SvPV_force(sv,PL_na); + SvPV_force(sv,n_a); while (!SvNIOKp(sv) && SvCUR(sv) <= len) { XPUSHs(sv); if (strEQ(SvPVX(sv),tmps)) @@ -1233,9 +1320,10 @@ dounwind(I32 cxix) } OP * -die_where(char *message) +die_where(char *message, STRLEN msglen) { dSP; + STRLEN n_a; if (PL_in_eval) { I32 cxix; register PERL_CONTEXT *cx; @@ -1245,9 +1333,8 @@ die_where(char *message) if (message) { if (PL_in_eval & 4) { SV **svp; - STRLEN klen = strlen(message); - svp = hv_fetch(ERRHV, message, klen, TRUE); + svp = hv_fetch(ERRHV, message, msglen, TRUE); if (svp) { if (!SvIOK(*svp)) { static char prefix[] = "\t(in cleanup) "; @@ -1256,11 +1343,11 @@ die_where(char *message) (void)SvIOK_only(*svp); if (!SvPOK(err)) sv_setpv(err,""); - SvGROW(err, SvCUR(err)+sizeof(prefix)+klen); + SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen); sv_catpvn(err, prefix, sizeof(prefix)-1); - sv_catpvn(err, message, klen); + sv_catpvn(err, message, msglen); if (ckWARN(WARN_UNSAFE)) { - STRLEN start = SvCUR(err)-klen-sizeof(prefix)+1; + STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1; warner(WARN_UNSAFE, SvPVX(err)+start); } } @@ -1268,10 +1355,10 @@ die_where(char *message) } } else - sv_setpv(ERRSV, message); + sv_setpvn(ERRSV, message, msglen); } else - message = SvPVx(ERRSV, PL_na); + message = SvPVx(ERRSV, msglen); while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { dounwind(-1); @@ -1286,7 +1373,8 @@ die_where(char *message) POPBLOCK(cx,PL_curpm); if (CxTYPE(cx) != CXt_EVAL) { - PerlIO_printf(PerlIO_stderr(), "panic: die %s", message); + PerlIO_write(PerlIO_stderr(), "panic: die ", 11); + PerlIO_write(PerlIO_stderr(), message, msglen); my_exit(1); } POPEVAL(cx); @@ -1298,16 +1386,25 @@ die_where(char *message) LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); } } if (!message) - message = SvPVx(ERRSV, PL_na); - PerlIO_printf(PerlIO_stderr(), "%s",message); - PerlIO_flush(PerlIO_stderr()); + message = SvPVx(ERRSV, msglen); + { +#ifdef USE_SFIO + /* SFIO can really mess with your errno */ + int e = errno; +#endif + PerlIO_write(PerlIO_stderr(), message, msglen); + (void)PerlIO_flush(PerlIO_stderr()); +#ifdef USE_SFIO + errno = e; +#endif + } my_failure_exit(); /* NOTREACHED */ return 0; @@ -1402,7 +1499,8 @@ PP(pp_caller) PUSHs(&PL_sv_undef); else PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0))); - PUSHs(sv_2mortal(newSVpv(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), 0))); + PUSHs(sv_2mortal(newSVpvn(SvPVX(GvSV(cx->blk_oldcop->cop_filegv)), + SvCUR(GvSV(cx->blk_oldcop->cop_filegv))))); PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->cop_line))); if (!MAXARG) RETURN; @@ -1413,7 +1511,7 @@ PP(pp_caller) PUSHs(sv_2mortal(newSViv((I32)cx->blk_sub.hasargs))); } else { - PUSHs(sv_2mortal(newSVpv("(eval)",0))); + PUSHs(sv_2mortal(newSVpvn("(eval)",6))); PUSHs(sv_2mortal(newSViv(0))); } gimme = (I32)cx->blk_gimme; @@ -1483,11 +1581,12 @@ PP(pp_reset) { djSP; char *tmps; + STRLEN n_a; if (MAXARG < 1) tmps = ""; else - tmps = POPp; + tmps = POPpx; sv_reset(tmps, PL_curcop->cop_stash); PUSHs(&PL_sv_yes); RETURN; @@ -1560,8 +1659,12 @@ PP(pp_enteriter) SAVETMPS; #ifdef USE_THREADS - if (PL_op->op_flags & OPf_SPECIAL) - svp = save_threadsv(PL_op->op_targ); /* per-thread variable */ + if (PL_op->op_flags & OPf_SPECIAL) { + dTHR; + svp = &THREADSV(PL_op->op_targ); /* per-thread variable */ + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); + } else #endif /* USE_THREADS */ if (PL_op->op_targ) { @@ -1569,9 +1672,9 @@ PP(pp_enteriter) SAVESPTR(*svp); } else { - GV *gv = (GV*)POPs; - (void)save_scalar(gv); - svp = &GvSV(gv); /* symbol table variable */ + svp = &GvSV((GV*)POPs); /* symbol table variable */ + SAVEGENERICSV(*svp); + *svp = NEWSV(0,0); } ENTER; @@ -1939,10 +2042,12 @@ PP(pp_goto) OP *enterops[GOTO_DEPTH]; char *label; int do_dump = (PL_op->op_type == OP_DUMP); + static char must_have_label[] = "goto must have label"; label = 0; if (PL_op->op_flags & OPf_STACKED) { SV *sv = POPs; + STRLEN n_a; /* This egregious kludge implements goto &subroutine */ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) { @@ -2026,6 +2131,7 @@ PP(pp_goto) /* Now do some callish stuff. */ SAVETMPS; if (CvXSUB(cv)) { +#ifdef PERL_XSUB_OLDSTYLE if (CvOLDSTYLE(cv)) { I32 (*fp3)_((int,int,int)); while (SP > mark) { @@ -2038,7 +2144,9 @@ PP(pp_goto) items); SP = PL_stack_base + items; } - else { + else +#endif /* PERL_XSUB_OLDSTYLE */ + { SV **newsp; I32 gimme; @@ -2191,12 +2299,15 @@ PP(pp_goto) RETURNOP(CvSTART(cv)); } } - else - label = SvPV(sv,PL_na); + else { + label = SvPV(sv,n_a); + if (!(do_dump || *label)) + DIE(must_have_label); + } } else if (PL_op->op_flags & OPf_SPECIAL) { if (! do_dump) - DIE("goto must have label"); + DIE(must_have_label); } else label = cPVOP->op_pv; @@ -2341,7 +2452,8 @@ PP(pp_cswitch) if (PL_multiline) PL_op = PL_op->op_next; /* can't assume anything */ else { - match = *(SvPVx(GvSV(cCOP->cop_gv), PL_na)) & 255; + STRLEN n_a; + match = *(SvPVx(GvSV(cCOP->cop_gv), n_a)) & 255; match -= cCOP->uop.scop.scop_offset; if (match < 0) match = 0; @@ -2521,7 +2633,7 @@ doeval(int gimme, OP** startop) SAVESPTR(PL_compcv); PL_compcv = (CV*)NEWSV(1104,0); sv_upgrade((SV *)PL_compcv, SVt_PVCV); - CvUNIQUE_on(PL_compcv); + CvEVAL_on(PL_compcv); #ifdef USE_THREADS CvOWNER(PL_compcv) = 0; New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); @@ -2536,7 +2648,7 @@ doeval(int gimme, OP** startop) PL_min_intro_pending = 0; PL_padix = 0; #ifdef USE_THREADS - av_store(PL_comppad_name, 0, newSVpv("@_", 2)); + av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); PL_curpad[0] = (SV*)newAV(); SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ #endif /* USE_THREADS */ @@ -2570,7 +2682,7 @@ doeval(int gimme, OP** startop) PL_curcop = &PL_compiling; PL_curcop->cop_arybase = 0; SvREFCNT_dec(PL_rs); - PL_rs = newSVpv("\n", 1); + PL_rs = newSVpvn("\n", 1); if (saveop && saveop->op_flags & OPf_SPECIAL) PL_in_eval |= 4; else @@ -2580,6 +2692,7 @@ doeval(int gimme, OP** startop) I32 gimme; PERL_CONTEXT *cx; I32 optype = 0; /* Might be reset by POPEVAL. */ + STRLEN n_a; PL_op = saveop; if (PL_eval_root) { @@ -2595,10 +2708,10 @@ doeval(int gimme, OP** startop) lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); DIE("%s", *msg ? msg : "Compilation failed in require"); } else if (startop) { - char* msg = SvPVx(ERRSV, PL_na); + char* msg = SvPVx(ERRSV, n_a); POPBLOCK(cx,PL_curpm); POPEVAL(cx); @@ -2659,6 +2772,35 @@ doeval(int gimme, OP** startop) RETURNOP(PL_eval_start); } +static PerlIO * +doopen(const char *name, const char *mode) +{ + STRLEN namelen = strlen(name); + PerlIO *fp; + + if (namelen > 3 && strcmp(name + namelen - 3, ".pm") == 0) { + SV *pmcsv = newSVpvf("%s%c", name, 'c'); + char *pmc = SvPV_nolen(pmcsv); + Stat_t pmstat; + Stat_t pmcstat; + if (PerlLIO_stat(pmc, &pmcstat) < 0) { + fp = PerlIO_open(name, mode); + } else { + if (PerlLIO_stat(name, &pmstat) < 0 || + pmstat.st_mtime < pmcstat.st_mtime) { + fp = PerlIO_open(pmc, mode); + } else { + fp = PerlIO_open(name, mode); + } + } + SvREFCNT_dec(pmcsv); + } else { + fp = PerlIO_open(name, mode); + } + + return fp; +} + PP(pp_require) { djSP; @@ -2671,13 +2813,14 @@ PP(pp_require) SV** svp; I32 gimme = G_SCALAR; PerlIO *tryrsfp = 0; + STRLEN n_a; sv = POPs; if (SvNIOKp(sv) && !SvPOKp(sv)) { SET_NUMERIC_STANDARD(); if (atof(PL_patchlevel) + 0.00000999 < SvNV(sv)) DIE("Perl %s required--this is only version %s, stopped", - SvPV(sv,PL_na),PL_patchlevel); + SvPV(sv,n_a),PL_patchlevel); RETPUSHYES; } name = SvPV(sv, len); @@ -2708,7 +2851,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE); + tryrsfp = doopen(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(PL_incgv); @@ -2720,7 +2863,7 @@ PP(pp_require) { namesv = NEWSV(806, 0); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); #ifdef VMS char *unixdir; if ((unixdir = tounixpath(dir, Nullch)) == Nullch) @@ -2732,7 +2875,7 @@ PP(pp_require) #endif TAINT_PROPER("require"); tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -2756,7 +2899,7 @@ PP(pp_require) sv_catpv(msg, " (did you run h2ph?)"); sv_catpv(msg, " (@INC contains:"); for (i = 0; i <= AvFILL(ar); i++) { - char *dir = SvPVx(*av_fetch(ar, i, TRUE), PL_na); + char *dir = SvPVx(*av_fetch(ar, i, TRUE), n_a); sv_setpvf(dirmsgsv, " %s", dir); sv_catsv(msg, dirmsgsv); } @@ -2776,7 +2919,7 @@ PP(pp_require) ENTER; SAVETMPS; - lex_start(sv_2mortal(newSVpv("",0))); + lex_start(sv_2mortal(newSVpvn("",0))); SAVEGENERICSV(PL_rsfp_filters); PL_rsfp_filters = Nullav;