: (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
{
SV *targ = cx->sb_targ;
- sv_catpvn(dstr, s, cx->sb_strend - s);
+ bool isutf8;
+ sv_catpvn(dstr, s, cx->sb_strend - s);
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
(void)SvOOK_off(targ);
SvPVX(targ) = SvPVX(dstr);
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
+ isutf8 = DO_UTF8(dstr);
SvPVX(dstr) = 0;
sv_free(dstr);
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
(void)SvPOK_only(targ);
+ if (isutf8)
+ SvUTF8_on(targ);
TAINT_IF(cx->sb_rxtainted);
SvSETMAGIC(targ);
SvTAINT(targ);
cx->sb_m = m = rx->startp[0] + orig;
sv_catpvn(dstr, s, m-s);
cx->sb_s = rx->endp[0] + orig;
+ { /* Update the pos() information. */
+ SV *sv = cx->sb_targ;
+ MAGIC *mg;
+ I32 i;
+ if (SvTYPE(sv) < SVt_PVMG)
+ SvUPGRADE(sv, SVt_PVMG);
+ if (!(mg = mg_find(sv, 'g'))) {
+ sv_magic(sv, Nullsv, 'g', Nullch, 0);
+ mg = mg_find(sv, 'g');
+ }
+ i = m - orig;
+ if (DO_UTF8(sv))
+ sv_pos_b2u(sv, &i);
+ mg->mg_len = i;
+ }
cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
rxres_save(&cx->sb_rxres, rx);
RETURNOP(pm->op_pmreplstart);
s = item;
if (item_is_utf) {
while (arg--) {
- if (*s & 0x80) {
+ if (UTF8_IS_CONTINUED(*s)) {
switch (UTF8SKIP(s)) {
case 7: *t++ = *s++;
case 6: *t++ = *s++;
value = SvNV(sv);
/* Formats aren't yet marked for locales, so assume "yes". */
{
- RESTORE_NUMERIC_LOCAL();
+ STORE_NUMERIC_STANDARD_SET_LOCAL();
#if defined(USE_LONG_DOUBLE)
if (arg & 256) {
sprintf(t, "%#*.*" PERL_PRIfldbl,
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;
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));
}
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 {
dTOPss;
SV *targ = PAD_SV(PL_op->op_targ);
-
- if ((PL_op->op_private & OPpFLIP_LINENUM)
- ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
- : SvTRUE(sv) ) {
+ int flip;
+
+ if (PL_op->op_private & OPpFLIP_LINENUM) {
+ struct io *gp_io;
+ flip = PL_last_in_gv
+ && (gp_io = GvIOp(PL_last_in_gv))
+ && SvIV(sv) == (IV)IoLINES(gp_io);
+ } else {
+ flip = SvTRUE(sv);
+ }
+ if (flip) {
sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
if (PL_op->op_flags & OPf_SPECIAL) {
sv_setiv(targ, 1);
STATIC I32
S_dopoptolabel(pTHX_ char *label)
{
- dTHR;
register I32 i;
register PERL_CONTEXT *cx;
I32
Perl_block_gimme(pTHX)
{
- dTHR;
I32 cxix;
cxix = dopoptosub(cxstack_ix);
}
}
+I32
+Perl_is_lvalue_sub(pTHX)
+{
+ I32 cxix;
+
+ cxix = dopoptosub(cxstack_ix);
+ assert(cxix >= 0); /* We should only be called from inside subs */
+
+ if (cxstack[cxix].blk_sub.lval && CvLVALUE(cxstack[cxix].blk_sub.cv))
+ return cxstack[cxix].blk_sub.lval;
+ else
+ return 0;
+}
+
STATIC I32
S_dopoptosub(pTHX_ I32 startingblock)
{
- dTHR;
return dopoptosub_at(cxstack, startingblock);
}
STATIC I32
S_dopoptosub_at(pTHX_ PERL_CONTEXT *cxstk, I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoeval(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
STATIC I32
S_dopoptoloop(pTHX_ I32 startingblock)
{
- dTHR;
I32 i;
register PERL_CONTEXT *cx;
for (i = startingblock; i >= 0; i--) {
void
Perl_dounwind(pTHX_ I32 cxix)
{
- dTHR;
register PERL_CONTEXT *cx;
I32 optype;
}
}
-/*
- * Closures mentioned at top level of eval cannot be referenced
- * again, and their presence indirectly causes a memory leak.
- * (Note that the fact that compcv and friends are still set here
- * is, AFAIK, an accident.) --Chip
- *
- * XXX need to get comppad et al from eval's cv rather than
- * relying on the incidental global values.
- */
-STATIC void
-S_free_closures(pTHX)
-{
- dTHR;
- SV **svp = AvARRAY(PL_comppad_name);
- I32 ix;
- for (ix = AvFILLp(PL_comppad_name); ix >= 0; ix--) {
- SV *sv = svp[ix];
- if (sv && sv != &PL_sv_undef && *SvPVX(sv) == '&') {
- SvREFCNT_dec(sv);
- svp[ix] = &PL_sv_undef;
-
- sv = PL_curpad[ix];
- if (CvCLONE(sv)) {
- SvREFCNT_dec(CvOUTSIDE(sv));
- CvOUTSIDE(sv) = Nullcv;
- }
- else {
- SvREFCNT_dec(sv);
- sv = NEWSV(0,0);
- SvPADTMP_on(sv);
- PL_curpad[ix] = sv;
- }
- }
- }
-}
-
void
Perl_qerror(pTHX_ SV *err)
{
LEAVE;
+ /* LEAVE could clobber PL_curcop (see save_re_context())
+ * XXX it might be better to find a way to avoid messing with
+ * PL_curcop in save_re_context() instead, but this is a more
+ * minimal fix --GSAR */
+ PL_curcop = cx->blk_oldcop;
+
if (optype == OP_REQUIRE) {
char* msg = SvPVx(ERRSV, n_a);
DIE(aTHX_ "%sCompilation failed in require",
#ifdef USE_THREADS
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) {
+#ifndef USE_ITHREADS
svp = &PL_curpad[PL_op->op_targ]; /* "my" variable */
SAVESPTR(*svp);
-#ifdef USE_ITHREADS
+#else
+ SAVEPADSV(PL_op->op_targ);
iterdata = (void*)PL_op->op_targ;
cxtype |= CXp_PADVAR;
#endif
POPEVAL(cx);
if (CxTRYBLOCK(cx))
break;
- if (AvFILLp(PL_comppad_name) >= 0)
- free_closures();
lex_end();
if (optype == OP_REQUIRE &&
(MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
}
*ops = 0;
if (o->op_flags & OPf_KIDS) {
- dTHR;
/* First try all the kids at this level, since that's likeliest. */
for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
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;
STATIC OP *
S_docatch(pTHX_ OP *o)
{
- dTHR;
int ret;
OP *oldop = PL_op;
volatile PERL_SI *cursi = PL_curstackinfo;
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PL_op->op_flags = 0; /* Avoid uninit warning. */
- PUSHBLOCK(cx, CXt_EVAL, SP);
+ PUSHBLOCK(cx, CXt_EVAL|(PL_curcop == &PL_compiling ? 0 : CXp_REAL), SP);
PUSHEVAL(cx, 0, Nullgv);
rop = doeval(G_SCALAR, startop);
POPBLOCK(cx,PL_curpm);
AV* comppadlist;
I32 i;
- PL_in_eval = EVAL_INEVAL;
+ PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
+ ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
+ : EVAL_INEVAL);
PUSHMARK(SP);
CvDEPTH(PL_compcv) = 1;
SP = PL_stack_base + POPMARK; /* pop original mark */
PL_op = saveop; /* The caller may need it. */
+ PL_lex_state = LEX_NOTPARSING; /* $^S needs this. */
#ifdef USE_THREADS
MUTEX_LOCK(&PL_eval_mutex);
PL_eval_owner = 0;
if (SvNIOKp(sv)) {
if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
UV rev = 0, ver = 0, sver = 0;
- I32 len;
+ STRLEN len;
U8 *s = (U8*)SvPVX(sv);
U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
if (s < end) {
- rev = utf8_to_uv(s, &len);
+ rev = utf8_to_uv(s, end - s, &len, 0);
s += len;
if (s < end) {
- ver = utf8_to_uv(s, &len);
+ ver = utf8_to_uv(s, end - s, &len, 0);
s += len;
if (s < end)
- sver = utf8_to_uv(s, &len);
+ sver = utf8_to_uv(s, end - s, &len, 0);
}
}
if (PERL_REVISION < rev
/* prepare to compile file */
+#ifdef MACOS_TRADITIONAL
if (PERL_FILE_IS_ABSOLUTE(name)
- || (*name == '.' && (name[1] == '/' ||
- (name[1] == '.' && name[2] == '/'))))
+ || (*name == ':' && name[1] != ':' && strchr(name+2, ':')))
{
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, ':'))
+ if (!tryrsfp && *name == ':' && name[1] != ':' && strchr(name+2, ':'))
goto trylocal;
}
else
trylocal: {
#else
+ if (PERL_FILE_IS_ABSOLUTE(name)
+ || (*name == '.' && (name[1] == '/' ||
+ (name[1] == '.' && name[2] == '/'))))
+ {
+ tryname = name;
+ tryrsfp = doopen_pmc(name,PERL_SCRIPT_MODE);
}
else {
#endif
if (io) {
tryrsfp = IoIFP(io);
- if (IoTYPE(io) == '|') {
+ if (IoTYPE(io) == IoTYPE_PIPE) {
/* reading from a child process doesn't
nest -- when returning from reading
the inner module, the outer one is
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] == ':'));
+ char buf[256];
+ Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf), name+(name[0] == ':'));
#else
#ifdef VMS
char *unixdir;
}
PL_curpm = newpm; /* Don't pop $1 et al till now */
- if (AvFILLp(PL_comppad_name) >= 0)
- free_closures();
-
#ifdef DEBUGGING
assert(CvDEPTH(PL_compcv) == 1);
#endif
static I32
sortcv(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
static I32
sortcv_stacked(pTHXo_ SV *a, SV *b)
{
- dTHR;
I32 oldsaveix = PL_savestack_ix;
I32 oldscopeix = PL_scopestack_ix;
I32 result;
https://perl5.git.perl.org / perl5.git / blobdiff