/* 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.
#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));
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));
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);
}
}
OP *
-die_where(char *message)
+die_where(char *message, STRLEN msglen)
{
dSP;
STRLEN n_a;
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) ";
(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);
}
}
}
}
else
- sv_setpv(ERRSV, message);
+ sv_setpvn(ERRSV, message, msglen);
}
else
- message = SvPVx(ERRSV, n_a);
+ message = SvPVx(ERRSV, msglen);
while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) {
dounwind(-1);
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);
}
}
if (!message)
- message = SvPVx(ERRSV, n_a);
- 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;
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;
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;
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) {
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;
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) {
/* Now do some callish stuff. */
SAVETMPS;
if (CvXSUB(cv)) {
+#ifdef PERL_XSUB_OLDSTYLE
if (CvOLDSTYLE(cv)) {
I32 (*fp3)_((int,int,int));
while (SP > mark) {
items);
SP = PL_stack_base + items;
}
- else {
+ else
+#endif /* PERL_XSUB_OLDSTYLE */
+ {
SV **newsp;
I32 gimme;
RETURNOP(CvSTART(cv));
}
}
- else
+ 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;
}
}
+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;
}
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);
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 */
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
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;
)
{
tryname = name;
- tryrsfp = PerlIO_open(name,PERL_SCRIPT_MODE);
+ tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
}
else {
AV *ar = GvAVn(PL_incgv);
#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;
ENTER;
SAVETMPS;
- lex_start(sv_2mortal(newSVpv("",0)));
+ lex_start(sv_2mortal(newSVpvn("",0)));
SAVEGENERICSV(PL_rsfp_filters);
PL_rsfp_filters = Nullav;
projects / p5sagit/p5-mst-13.2.git / blobdiff