PP(pp_mapwhile)
{
djSP;
- I32 diff = (SP - PL_stack_base) - *PL_markstack_ptr;
+ I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
I32 count;
I32 shift;
SV** src;
SV** dst;
+ /* first, move source pointer to the next item in the source list */
++PL_markstack_ptr[-1];
- if (diff) {
- if (diff > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
- shift = diff - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
- count = (SP - PL_stack_base) - PL_markstack_ptr[-1] + 2;
+
+ /* if there are new items, push them into the destination list */
+ if (items) {
+ /* might need to make room back there first */
+ if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
+ /* XXX this implementation is very pessimal because the stack
+ * is repeatedly extended for every set of items. Is possible
+ * to do this without any stack extension or copying at all
+ * by maintaining a separate list over which the map iterates
+ * (like foreach does). --gsar */
+
+ /* everything in the stack after the destination list moves
+ * towards the end the stack by the amount of room needed */
+ shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
+
+ /* items to shift up (accounting for the moved source pointer) */
+ count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
+
+ /* This optimization is by Ben Tilly and it does
+ * things differently from what Sarathy (gsar)
+ * is describing. The downside of this optimization is
+ * that leaves "holes" (uninitialized and hopefully unused areas)
+ * to the Perl stack, but on the other hand this
+ * shouldn't be a problem. If Sarathy's idea gets
+ * implemented, this optimization should become
+ * irrelevant. --jhi */
+ if (shift < count)
+ shift = count; /* Avoid shifting too often --Ben Tilly */
EXTEND(SP,shift);
src = SP;
dst = (SP += shift);
PL_markstack_ptr[-1] += shift;
*PL_markstack_ptr += shift;
- while (--count)
+ while (count--)
*dst-- = *src--;
}
- dst = PL_stack_base + (PL_markstack_ptr[-2] += diff) - 1;
- ++diff;
- while (--diff)
+ /* copy the new items down to the destination list */
+ dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
+ while (items--)
*dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
}
LEAVE; /* exit inner scope */
/* All done yet? */
if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
- I32 items;
I32 gimme = GIMME_V;
(void)POPMARK; /* pop top */
ENTER; /* enter inner scope */
SAVEVPTR(PL_curpm);
+ /* set $_ to the new source item */
src = PL_stack_base[PL_markstack_ptr[-1]];
SvTEMP_off(src);
DEFSV = src;
CATCH_SET(TRUE);
PUSHSTACKi(PERLSI_SORT);
- if (PL_sortstash != stash) {
- PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
- PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
- PL_sortstash = stash;
+ if (!hasargs && !is_xsub) {
+ if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
+ SAVESPTR(PL_firstgv);
+ SAVESPTR(PL_secondgv);
+ PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
+ PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
+ PL_sortstash = stash;
+ }
+#ifdef USE_THREADS
+ sv_lock((SV *)PL_firstgv);
+ sv_lock((SV *)PL_secondgv);
+#endif
+ SAVESPTR(GvSV(PL_firstgv));
+ SAVESPTR(GvSV(PL_secondgv));
}
- SAVESPTR(GvSV(PL_firstgv));
- SAVESPTR(GvSV(PL_secondgv));
-
PUSHBLOCK(cx, CXt_NULL, PL_stack_base);
if (!(PL_op->op_flags & OPf_SPECIAL)) {
cx->cx_type = CXt_SUB;
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
#endif /* USE_THREADS */
+ cx->blk_sub.oldcurpad = PL_curpad;
cx->blk_sub.argarray = av;
}
qsortsv((myorigmark+1), max,
else
PUSHs(sv_2mortal(newSViv(gimme & G_ARRAY)));
if (CxTYPE(cx) == CXt_EVAL) {
+ /* eval STRING */
if (cx->blk_eval.old_op_type == OP_ENTEREVAL) {
PUSHs(cx->blk_eval.cur_text);
PUSHs(&PL_sv_no);
}
- /* try blocks have old_namesv == 0 */
+ /* require */
else if (cx->blk_eval.old_namesv) {
PUSHs(sv_2mortal(newSVsv(cx->blk_eval.old_namesv)));
PUSHs(&PL_sv_yes);
}
+ /* eval BLOCK (try blocks have old_namesv == 0) */
+ else {
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_undef);
+ }
}
else {
PUSHs(&PL_sv_undef);
PL_dbargs = GvAV(gv_AVadd(tmpgv = gv_fetchpv("DB::args", TRUE,
SVt_PVAV)));
GvMULTI_on(tmpgv);
- AvREAL_off(PL_dbargs); /* XXX Should be REIFY */
+ AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */
}
if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
{
SV * mask ;
SV * old_warnings = cx->blk_oldcop->cop_warnings ;
- if (old_warnings == WARN_NONE || old_warnings == WARN_STD)
+
+ if (old_warnings == pWARN_NONE ||
+ (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
mask = newSVpvn(WARN_NONEstring, WARNsize) ;
- else if (old_warnings == WARN_ALL)
+ else if (old_warnings == pWARN_ALL ||
+ (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON))
mask = newSVpvn(WARN_ALLstring, WARNsize) ;
else
mask = newSVsv(old_warnings);
I32 cxix;
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
+ bool clear_errsv = FALSE;
I32 gimme;
SV **newsp;
PMOP *newpm;
popsub2 = TRUE;
break;
case CXt_EVAL:
+ if (!(PL_in_eval & EVAL_KEEPERR))
+ clear_errsv = TRUE;
POPEVAL(cx);
if (CxTRYBLOCK(cx))
break;
*++newsp = SvREFCNT_inc(*SP);
FREETMPS;
sv_2mortal(*newsp);
- } else {
+ }
+ else {
+ sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
FREETMPS;
- *++newsp = sv_mortalcopy(*SP);
+ *++newsp = sv_mortalcopy(sv);
+ SvREFCNT_dec(sv);
}
- } else
+ }
+ else
*++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
- } else
+ }
+ else
*++newsp = sv_mortalcopy(*SP);
- } else
+ }
+ else
*++newsp = &PL_sv_undef;
}
else if (gimme == G_ARRAY) {
LEAVE;
LEAVESUB(sv);
+ if (clear_errsv)
+ sv_setpv(ERRSV,"");
return pop_return();
}
{
I32 cxix;
register PERL_CONTEXT *cx;
- I32 oldsave;
+ I32 inner;
if (PL_op->op_flags & OPf_SPECIAL) {
cxix = dopoptoloop(cxstack_ix);
if (cxix < cxstack_ix)
dounwind(cxix);
+ /* clear off anything above the scope we're re-entering, but
+ * save the rest until after a possible continue block */
+ inner = PL_scopestack_ix;
TOPBLOCK(cx);
-
- /* clean scope, but only if there's no continue block */
- if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) {
- oldsave = PL_scopestack[PL_scopestack_ix - 1];
- LEAVE_SCOPE(oldsave);
- }
+ if (PL_scopestack_ix < inner)
+ leave_scope(PL_scopestack[PL_scopestack_ix]);
return cx->blk_loop.next_op;
}
cx->blk_sub.savearray = GvAV(PL_defgv);
GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
#endif /* USE_THREADS */
+ cx->blk_sub.oldcurpad = PL_curpad;
cx->blk_sub.argarray = av;
++mark;
anum = 0;
else {
anum = SvIVx(POPs);
-#ifdef VMSISH_EXIT
- if (anum == 1 && VMSISH_EXIT)
+#ifdef VMS
+ if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
anum = 0;
#endif
}
/* switch to eval mode */
if (PL_curcop == &PL_compiling) {
- SAVECOPSTASH(&PL_compiling);
+ SAVECOPSTASH_FREE(&PL_compiling);
CopSTASH_set(&PL_compiling, PL_curstash);
}
- SAVECOPFILE(&PL_compiling);
- SAVECOPLINE(&PL_compiling);
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
SV *sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
}
else
sprintf(tmpbuf, "_<(%.10s_eval %lu)", code, (unsigned long)++PL_evalseq);
+ SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
+ SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 1);
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
deleting the eval's FILEGV from the stash before gv_check() runs
SAVESPTR(PL_beginav);
PL_beginav = newAV();
SAVEFREESV(PL_beginav);
+ SAVEI32(PL_error_count);
/* try to compile it */
sv = POPs;
if (SvNIOKp(sv)) {
- UV rev, ver, sver;
- if (SvPOKp(sv)) { /* require v5.6.1 */
+ if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
+ UV rev = 0, ver = 0, sver = 0;
I32 len;
U8 *s = (U8*)SvPVX(sv);
U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
s += len;
if (s < end)
sver = utf8_to_uv(s, &len);
- else
- sver = 0;
}
- else
- ver = 0;
}
- else
- rev = 0;
if (PERL_REVISION < rev
|| (PERL_REVISION == rev
&& (PERL_VERSION < ver
|| (PERL_VERSION == ver
&& PERL_SUBVERSION < sver))))
{
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
+ DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only "
"v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
PERL_VERSION, PERL_SUBVERSION);
}
+ RETPUSHYES;
}
else if (!SvPOKp(sv)) { /* require 5.005_03 */
if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
NV nsver = (nver - ver) * 1000;
UV sver = (UV)(nsver + 0.0009);
- DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
- "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
- PERL_VERSION, PERL_SUBVERSION);
+ /* help out with the "use 5.6" confusion */
+ if (sver == 0 && (rev > 5 || (rev == 5 && ver >= 100))) {
+ DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
+ "this is only v%d.%d.%d, stopped"
+ " (did you mean v%"UVuf".%"UVuf".0?)",
+ rev, ver, sver, PERL_REVISION, PERL_VERSION,
+ PERL_SUBVERSION, rev, ver/100);
+ }
+ else {
+ DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--"
+ "this is only v%d.%d.%d, stopped",
+ rev, ver, sver, PERL_REVISION, PERL_VERSION,
+ PERL_SUBVERSION);
+ }
}
+ RETPUSHYES;
}
- RETPUSHYES;
}
name = SvPV(sv, len);
if (!(name && len > 0 && *name))
{
tryname = name;
tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
+#ifdef MACOS_TRADITIONAL
+ /* We consider paths of the form :a:b ambiguous and interpret them first
+ as global then as local
+ */
+ if (!tryrsfp && name[0] == ':' && name[1] != ':' && strchr(name+2, ':'))
+ goto trylocal;
+ }
+ else
+trylocal: {
+#else
}
else {
+#endif
AV *ar = GvAVn(PL_incgv);
I32 i;
#ifdef VMS
}
else {
char *dir = SvPVx(dirsv, n_a);
+#ifdef MACOS_TRADITIONAL
+ /* We have ensured in incpush that library ends with ':' */
+ Perl_sv_setpvf(aTHX_ namesv, "%s%s", dir, name+(name[0] == ':'));
+#else
#ifdef VMS
char *unixdir;
if ((unixdir = tounixpath(dir, Nullch)) == Nullch)
#else
Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
#endif
+#endif
TAINT_PROPER("require");
tryname = SvPVX(namesv);
+#ifdef MACOS_TRADITIONAL
+ {
+ /* Convert slashes in the name part, but not the directory part, to colons */
+ char * colon;
+ for (colon = tryname+strlen(dir); colon = strchr(colon, '/'); )
+ *colon++ = ':';
+ }
+#endif
tryrsfp = doopen_pmc(tryname, PERL_SCRIPT_MODE);
if (tryrsfp) {
if (tryname[0] == '.' && tryname[1] == '/')
}
}
}
- SAVECOPFILE(&PL_compiling);
+ SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
SvREFCNT_dec(namesv);
if (!tryrsfp) {
PL_hints = 0;
SAVESPTR(PL_compiling.cop_warnings);
if (PL_dowarn & G_WARN_ALL_ON)
- PL_compiling.cop_warnings = WARN_ALL ;
+ PL_compiling.cop_warnings = pWARN_ALL ;
else if (PL_dowarn & G_WARN_ALL_OFF)
- PL_compiling.cop_warnings = WARN_NONE ;
+ PL_compiling.cop_warnings = pWARN_NONE ;
else
- PL_compiling.cop_warnings = WARN_STD ;
+ PL_compiling.cop_warnings = pWARN_STD ;
if (filter_sub || filter_child_proc) {
SV *datasv = filter_add(run_user_filter, Nullsv);
/* switch to eval mode */
- SAVECOPFILE(&PL_compiling);
if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
SV *sv = sv_newmortal();
Perl_sv_setpvf(aTHX_ sv, "_<(eval %lu)[%s:%"IVdf"]",
}
else
sprintf(tmpbuf, "_<(eval %lu)", (unsigned long)++PL_evalseq);
+ SAVECOPFILE_FREE(&PL_compiling);
CopFILE_set(&PL_compiling, tmpbuf+2);
+ SAVECOPLINE(&PL_compiling);
CopLINE_set(&PL_compiling, 1);
/* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
deleting the eval's FILEGV from the stash before gv_check() runs
SAVEHINTS();
PL_hints = PL_op->op_targ;
SAVESPTR(PL_compiling.cop_warnings);
- if (!specialWARN(PL_compiling.cop_warnings)) {
- PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
- SAVEFREESV(PL_compiling.cop_warnings) ;
+ if (specialWARN(PL_curcop->cop_warnings))
+ PL_compiling.cop_warnings = PL_curcop->cop_warnings;
+ else {
+ PL_compiling.cop_warnings = newSVsv(PL_curcop->cop_warnings);
+ SAVEFREESV(PL_compiling.cop_warnings);
}
push_return(PL_op->op_next);
projects / p5sagit/p5-mst-13.2.git / blobdiff