X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/127ad2b7f46b3b186ffbada86b1d7dda9ffd2a05..c8c62db702b7e7b28e0c00febb0781eff4341baf:/pp_ctl.c diff --git a/pp_ctl.c b/pp_ctl.c index fbfcab5..621024a 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. @@ -29,6 +29,7 @@ #define CALLOP this->*PL_op #else #define CALLOP *PL_op +static void *docatch_body _((void *o)); static OP *docatch _((OP *o)); static OP *dofindlabel _((OP *o, char *label, OP **opstack, OP **oplimit)); static void doparseform _((SV *sv)); @@ -41,6 +42,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_pmc _((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 @@ -166,7 +172,8 @@ PP(pp_substcont) if (cx->sb_once || !CALLREGEXEC(rx, s, cx->sb_strend, orig, s == m, cx->sb_targ, NULL, ((cx->sb_rflags & REXEC_COPY_STR) - ? 0 : REXEC_COPY_STR))) + ? REXEC_IGNOREPOS + : (REXEC_COPY_STR|REXEC_IGNOREPOS)))) { SV *targ = cx->sb_targ; sv_catpvn(dstr, s, cx->sb_strend - s); @@ -752,6 +759,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) { \ @@ -764,6 +785,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; @@ -872,10 +937,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++; } @@ -923,13 +989,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; @@ -984,33 +1067,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)) @@ -1230,9 +1321,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; @@ -1242,9 +1334,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) "; @@ -1253,11 +1344,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); } } @@ -1265,10 +1356,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); @@ -1283,7 +1374,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); @@ -1295,16 +1387,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; @@ -1399,7 +1500,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; @@ -1410,7 +1512,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; @@ -1480,11 +1582,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; @@ -1557,8 +1660,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) { @@ -1566,9 +1673,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; @@ -1936,10 +2043,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) { @@ -2023,6 +2132,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) { @@ -2035,7 +2145,9 @@ PP(pp_goto) items); SP = PL_stack_base + items; } - else { + else +#endif /* PERL_XSUB_OLDSTYLE */ + { SV **newsp; I32 gimme; @@ -2188,12 +2300,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; @@ -2338,7 +2453,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; @@ -2376,38 +2492,41 @@ save_lines(AV *array, SV *sv) } } +STATIC void * +docatch_body(va_list args) +{ + CALLRUNOPS(); + return NULL; +} + STATIC OP * docatch(OP *o) { dTHR; int ret; OP *oldop = PL_op; - dJMPENV; - PL_op = o; #ifdef DEBUGGING assert(CATCH_GET == TRUE); - DEBUG_l(deb("Setting up local jumplevel %p, was %p\n", &cur_env, PL_top_env)); #endif - JMPENV_PUSH(ret); + PL_op = o; + redo_body: + CALLPROTECT(&ret, FUNC_NAME_TO_PTR(docatch_body)); switch (ret) { - default: /* topmost level handles it */ -pass_the_buck: - JMPENV_POP; + case 0: + break; + case 3: + if (PL_restartop) { + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } + /* FALL THROUGH */ + default: PL_op = oldop; JMPENV_JUMP(ret); /* NOTREACHED */ - case 3: - if (!PL_restartop) - goto pass_the_buck; - PL_op = PL_restartop; - PL_restartop = 0; - /* FALL THROUGH */ - case 0: - CALLRUNOPS(); - break; } - JMPENV_POP; PL_op = oldop; return Nullop; } @@ -2518,7 +2637,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); @@ -2533,7 +2652,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 */ @@ -2567,7 +2686,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 @@ -2577,6 +2696,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) { @@ -2592,10 +2712,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); @@ -2656,6 +2776,38 @@ doeval(int gimme, OP** startop) RETURNOP(PL_eval_start); } +STATIC PerlIO * +doopen_pmc(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; @@ -2668,13 +2820,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); @@ -2705,7 +2858,7 @@ PP(pp_require) ) { tryname = name; - tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE); + tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE); } else { AV *ar = GvAVn(PL_incgv); @@ -2717,7 +2870,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) @@ -2729,7 +2882,7 @@ PP(pp_require) #endif TAINT_PROPER("require"); tryname = SvPVX(namesv); - tryrsfp = PerlIO_open(tryname, PERL_SCRIPT_MODE); + tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE); if (tryrsfp) { if (tryname[0] == '.' && tryname[1] == '/') tryname += 2; @@ -2753,7 +2906,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); } @@ -2773,7 +2926,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;