/* pp_ctl.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, 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.
PP(pp_wantarray)
{
- djSP;
+ dSP;
I32 cxix;
EXTEND(SP, 1);
PP(pp_regcomp)
{
- djSP;
+ dSP;
register PMOP *pm = (PMOP*)cLOGOP->op_other;
register char *t;
SV *tmpstr;
STRLEN len;
MAGIC *mg = Null(MAGIC*);
-
+
tmpstr = POPs;
+
+ /* prevent recompiling under /o and ithreads. */
+#if defined(USE_ITHREADS) || defined(USE_THREADS)
+ if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm))
+ RETURN;
+#endif
+
if (SvROK(tmpstr)) {
SV *sv = SvRV(tmpstr);
if(SvMAGICAL(sv))
- mg = mg_find(sv, 'r');
+ mg = mg_find(sv, PERL_MAGIC_qr);
}
if (mg) {
regexp *re = (regexp *)mg->mg_obj;
- ReREFCNT_dec(pm->op_pmregexp);
- pm->op_pmregexp = ReREFCNT_inc(re);
+ ReREFCNT_dec(PM_GETRE(pm));
+ PM_SETRE(pm, ReREFCNT_inc(re));
}
else {
t = SvPV(tmpstr, len);
/* Check against the last compiled regexp. */
- if (!pm->op_pmregexp || !pm->op_pmregexp->precomp ||
- pm->op_pmregexp->prelen != len ||
- memNE(pm->op_pmregexp->precomp, t, len))
+ if (!PM_GETRE(pm) || !PM_GETRE(pm)->precomp ||
+ PM_GETRE(pm)->prelen != len ||
+ memNE(PM_GETRE(pm)->precomp, t, len))
{
- if (pm->op_pmregexp) {
- ReREFCNT_dec(pm->op_pmregexp);
- pm->op_pmregexp = Null(REGEXP*); /* crucial if regcomp aborts */
+ if (PM_GETRE(pm)) {
+ ReREFCNT_dec(PM_GETRE(pm));
+ PM_SETRE(pm, Null(REGEXP*)); /* crucial if regcomp aborts */
}
if (PL_op->op_flags & OPf_SPECIAL)
PL_reginterp_cnt = I32_MAX; /* Mark as safe. */
pm->op_pmflags = pm->op_pmpermflags; /* reset case sensitivity */
if (DO_UTF8(tmpstr))
- pm->op_pmdynflags |= PMdf_UTF8;
- pm->op_pmregexp = CALLREGCOMP(aTHX_ t, t + len, pm);
- PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
+ pm->op_pmdynflags |= PMdf_DYN_UTF8;
+ else {
+ pm->op_pmdynflags &= ~PMdf_DYN_UTF8;
+ if (pm->op_pmdynflags & PMdf_UTF8)
+ t = (char*)bytes_to_utf8((U8*)t, &len);
+ }
+ PM_SETRE(pm, CALLREGCOMP(aTHX_ t, t + len, pm));
+ if (!DO_UTF8(tmpstr) && (pm->op_pmdynflags & PMdf_UTF8))
+ Safefree(t);
+ PL_reginterp_cnt = 0; /* XXXX Be extra paranoid - needed
inside tie/overload accessors. */
}
}
}
#endif
- if (!pm->op_pmregexp->prelen && PL_curpm)
+ if (!PM_GETRE(pm)->prelen && PL_curpm)
pm = PL_curpm;
- else if (strEQ("\\s+", pm->op_pmregexp->precomp))
+ else if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
+ else
+ pm->op_pmflags &= ~PMf_WHITE;
/* XXX runtime compiled output needs to move to the pad */
if (pm->op_pmflags & PMf_KEEP) {
PP(pp_substcont)
{
- djSP;
+ dSP;
register PMOP *pm = (PMOP*) cLOGOP->op_other;
register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
register SV *dstr = cx->sb_dstr;
register char *m = cx->sb_m;
char *orig = cx->sb_orig;
register REGEXP *rx = cx->sb_rx;
-
+
rxres_restore(&cx->sb_rxres, rx);
if (cx->sb_iters++) {
SvPVX(targ) = SvPVX(dstr);
SvCUR_set(targ, SvCUR(dstr));
SvLEN_set(targ, SvLEN(dstr));
+ if (DO_UTF8(dstr))
+ SvUTF8_on(targ);
SvPVX(dstr) = 0;
sv_free(dstr);
TAINT_IF(cx->sb_rxtainted & 1);
- if (pm->op_pmdynflags & PMdf_UTF8)
- SvUTF8_on(targ); /* could also copy SvUTF8(dstr)? */
PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
(void)SvPOK_only_UTF8(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');
+ (void)SvUPGRADE(sv, SVt_PVMG);
+ if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
+ sv_magic(sv, Nullsv, PERL_MAGIC_regex_global, Nullch, 0);
+ mg = mg_find(sv, PERL_MAGIC_regex_global);
}
i = m - orig;
if (DO_UTF8(sv))
PP(pp_formline)
{
- djSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
register SV *tmpForm = *++MARK;
register U16 *fpc;
register char *t;
register char *s;
register char *send;
register I32 arg;
- register SV *sv;
- char *item;
- I32 itemsize;
- I32 fieldsize;
+ register SV *sv = Nullsv;
+ char *item = Nullch;
+ I32 itemsize = 0;
+ I32 fieldsize = 0;
I32 lines = 0;
bool chopspace = (strchr(PL_chopset, ' ') != Nullch);
- char *chophere;
- char *linemark;
+ char *chophere = Nullch;
+ char *linemark = Nullch;
NV value;
- bool gotsome;
+ bool gotsome = FALSE;
STRLEN len;
- STRLEN fudge = SvCUR(tmpForm) * (IN_BYTE ? 1 : 3) + 1;
+ STRLEN fudge = SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1;
bool item_is_utf = FALSE;
if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
else
PerlIO_printf(Perl_debug_log, "%-16s\n", name);
- } )
+ } );
switch (*fpc++) {
case FF_LINEMARK:
linemark = t;
s = item;
if (item_is_utf) {
while (arg--) {
- if (*s & 0x80) {
- switch (UTF8SKIP(s)) {
+ if (UTF8_IS_CONTINUED(*s)) {
+ STRLEN skip = UTF8SKIP(s);
+ switch (skip) {
+ default:
+ Move(s,t,skip,char);
+ s += skip;
+ t += skip;
+ break;
case 7: *t++ = *s++;
case 6: *t++ = *s++;
case 5: *t++ = *s++;
PP(pp_grepstart)
{
- djSP;
+ dSP;
SV *src;
if (PL_stack_base + *PL_markstack_ptr == SP) {
PP(pp_mapwhile)
{
- djSP;
+ dSP;
I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
I32 count;
I32 shift;
PP(pp_sort)
{
- djSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
register SV **up;
SV **myorigmark = ORIGMARK;
register I32 max;
HV *stash;
GV *gv;
- CV *cv;
+ CV *cv = 0;
I32 gimme = GIMME;
OP* nextop = PL_op->op_next;
I32 overloading = 0;
? ( (PL_op->op_private & OPpSORT_INTEGER)
? ( overloading ? amagic_i_ncmp : sv_i_ncmp)
: ( overloading ? amagic_ncmp : sv_ncmp))
- : ( (PL_op->op_private & OPpLOCALE)
+ : ( IN_LOCALE_RUNTIME
? ( overloading
? amagic_cmp_locale
: sv_cmp_locale_static)
PP(pp_flip)
{
- djSP;
+ dSP;
if (GIMME == G_ARRAY) {
RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
if (PL_op->op_private & OPpFLIP_LINENUM) {
struct io *gp_io;
flip = PL_last_in_gv
- && (gp_io = GvIOp(PL_last_in_gv))
+ && (gp_io = GvIO(PL_last_in_gv))
&& SvIV(sv) == (IV)IoLINES(gp_io);
} else {
flip = SvTRUE(sv);
PP(pp_flop)
{
- djSP;
+ dSP;
if (GIMME == G_ARRAY) {
dPOPPOPssrl;
SV *targ = PAD_SV(cUNOP->op_first->op_targ);
sv_inc(targ);
if ((PL_op->op_private & OPpFLIP_LINENUM)
- ? (PL_last_in_gv && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
+ ? (GvIO(PL_last_in_gv)
+ && SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv)))
: SvTRUE(sv) ) {
sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
sv_catpv(targ, "E0");
}
}
+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)
{
}
}
-/*
- * 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)
-{
- 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)
{
}
}
}
- else
+ else {
sv_setpvn(ERRSV, message, msglen);
+ }
}
else
message = SvPVx(ERRSV, msglen);
PP(pp_xor)
{
- djSP; dPOPTOPssrl;
+ dSP; dPOPTOPssrl;
if (SvTRUE(left) != SvTRUE(right))
RETSETYES;
else
PP(pp_andassign)
{
- djSP;
+ dSP;
if (!SvTRUE(TOPs))
RETURN;
else
PP(pp_orassign)
{
- djSP;
+ dSP;
if (SvTRUE(TOPs))
RETURN;
else
PP(pp_caller)
{
- djSP;
+ dSP;
register I32 cxix = dopoptosub(cxstack_ix);
register PERL_CONTEXT *cx;
register PERL_CONTEXT *ccstack = cxstack;
if (MAXARG)
count = POPi;
- EXTEND(SP, 10);
+
for (;;) {
/* we may be in a higher stacklevel, so dig down deeper */
while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
cxix = dopoptosub_at(ccstack, top_si->si_cxix);
}
if (cxix < 0) {
- if (GIMME != G_ARRAY)
+ if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
RETPUSHUNDEF;
+ }
RETURN;
}
if (PL_DBsub && cxix >= 0 &&
stashname = CopSTASHPV(cx->blk_oldcop);
if (GIMME != G_ARRAY) {
+ EXTEND(SP, 1);
if (!stashname)
PUSHs(&PL_sv_undef);
else {
RETURN;
}
+ EXTEND(SP, 10);
+
if (!stashname)
PUSHs(&PL_sv_undef);
else
PP(pp_reset)
{
- djSP;
+ dSP;
char *tmps;
STRLEN n_a;
if (PL_op->op_private || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
{
- djSP;
+ dSP;
register CV *cv;
register PERL_CONTEXT *cx;
I32 gimme = G_ARRAY;
if (!cv)
DIE(aTHX_ "No DB::DB routine defined");
- if (CvDEPTH(cv) >= 1 && !(PL_debug & (1<<30))) /* don't do recursive DB::DB call */
+ if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
+ /* don't do recursive DB::DB call */
return NORMAL;
ENTER;
PP(pp_enteriter)
{
- djSP; dMARK;
+ dSP; dMARK;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
SV **svp;
PP(pp_enterloop)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
PP(pp_leaveloop)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
PP(pp_return)
{
- djSP; dMARK;
+ dSP; dMARK;
I32 cxix;
register PERL_CONTEXT *cx;
bool popsub2 = FALSE;
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))) )
PP(pp_last)
{
- djSP;
+ dSP;
I32 cxix;
register PERL_CONTEXT *cx;
I32 pop2 = 0;
PP(pp_goto)
{
- djSP;
+ dSP;
OP *retop = 0;
I32 ix;
register PERL_CONTEXT *cx;
if (cxix < cxstack_ix)
dounwind(cxix);
TOPBLOCK(cx);
- if (CxTYPE(cx) == CXt_EVAL && cx->blk_eval.old_op_type == OP_ENTEREVAL)
+ if (CxREALEVAL(cx))
DIE(aTHX_ "Can't goto subroutine from an eval-string");
mark = PL_stack_sp;
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
if (label && *label) {
OP *gotoprobe = 0;
+ bool leaving_eval = FALSE;
+ PERL_CONTEXT *last_eval_cx = 0;
/* find label */
cx = &cxstack[ix];
switch (CxTYPE(cx)) {
case CXt_EVAL:
- gotoprobe = PL_eval_root; /* XXX not good for nested eval */
- break;
+ leaving_eval = TRUE;
+ if (CxREALEVAL(cx)) {
+ gotoprobe = (last_eval_cx ?
+ last_eval_cx->blk_eval.old_eval_root :
+ PL_eval_root);
+ last_eval_cx = cx;
+ break;
+ }
+ /* else fall through */
case CXt_LOOP:
gotoprobe = cx->blk_oldcop->op_sibling;
break;
if (!retop)
DIE(aTHX_ "Can't find label %s", label);
+ /* if we're leaving an eval, check before we pop any frames
+ that we're not going to punt, otherwise the error
+ won't be caught */
+
+ if (leaving_eval && *enterops && enterops[1]) {
+ I32 i;
+ for (i = 1; enterops[i]; i++)
+ if (enterops[i]->op_type == OP_ENTERITER)
+ DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
+ }
+
/* pop unwanted frames */
if (ix < cxstack_ix) {
PP(pp_exit)
{
- djSP;
+ dSP;
I32 anum;
if (MAXARG < 1)
#ifdef NOTYET
PP(pp_nswitch)
{
- djSP;
+ dSP;
NV value = SvNVx(GvSV(cCOP->cop_gv));
register I32 match = I_32(value);
PP(pp_cswitch)
{
- djSP;
+ dSP;
register I32 match;
if (PL_multiline)
#else
SAVEVPTR(PL_op);
#endif
- PL_hints = 0;
+ PL_hints &= HINT_UTF8;
PL_op = &dummy;
PL_op->op_type = OP_ENTEREVAL;
PL_compcv = (CV*)NEWSV(1104,0);
sv_upgrade((SV *)PL_compcv, SVt_PVCV);
CvEVAL_on(PL_compcv);
+ assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
+ cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
+
#ifdef USE_THREADS
CvOWNER(PL_compcv) = 0;
New(666, CvMUTEXP(PL_compcv), 1, perl_mutex);
CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
}
- SAVEFREESV(PL_compcv);
+ SAVEMORTALIZESV(PL_compcv); /* must remain until end of current statement */
/* make sure we compile in the right package */
PP(pp_require)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
SV *sv;
char *name;
STRLEN len;
- char *tryname;
+ char *tryname = Nullch;
SV *namesv = Nullsv;
SV** svp;
- I32 gimme = G_SCALAR;
+ I32 gimme = GIMME_V;
PerlIO *tryrsfp = 0;
STRLEN n_a;
int filter_has_file = 0;
sv = POPs;
if (SvNIOKp(sv)) {
- if (SvPOK(sv) && SvNOK(sv)) { /* require v5.6.1 */
+ if (SvPOK(sv) && SvNOK(sv) && SvNV(sv)) { /* require v5.6.1 */
UV rev = 0, ver = 0, sver = 0;
STRLEN len;
U8 *s = (U8*)SvPVX(sv);
U8 *end = (U8*)SvPVX(sv) + SvCUR(sv);
if (s < end) {
- rev = utf8_to_uv(s, end - s, &len, 0);
+ rev = utf8n_to_uvchr(s, end - s, &len, 0);
s += len;
if (s < end) {
- ver = utf8_to_uv(s, end - s, &len, 0);
+ ver = utf8n_to_uvchr(s, end - s, &len, 0);
s += len;
if (s < end)
- sver = utf8_to_uv(s, end - s, &len, 0);
+ sver = utf8n_to_uvchr(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
PUSHs(dirsv);
PUSHs(sv);
PUTBACK;
- count = call_sv(loader, G_ARRAY);
+ if (sv_isobject(loader))
+ count = call_method("INC", G_ARRAY);
+ else
+ count = call_sv(loader, G_ARRAY);
SPAGAIN;
if (count > 0) {
PL_eval_owner = thr;
MUTEX_UNLOCK(&PL_eval_mutex);
#endif /* USE_THREADS */
- return DOCATCH(doeval(G_SCALAR, NULL));
+ return DOCATCH(doeval(gimme, NULL));
}
PP(pp_dofile)
PP(pp_entereval)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
dPOPss;
I32 gimme = GIMME_V, was = PL_sub_generation;
PP(pp_leaveeval)
{
- djSP;
+ dSP;
register SV **mark;
SV **newsp;
PMOP *newpm;
}
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
PP(pp_entertry)
{
- djSP;
+ dSP;
register PERL_CONTEXT *cx;
I32 gimme = GIMME_V;
push_return(cLOGOP->op_other->op_next);
PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), SP);
PUSHEVAL(cx, 0, 0);
- PL_eval_root = PL_op; /* Only needed so that goto works right. */
PL_in_eval = EVAL_INEVAL;
sv_setpv(ERRSV,"");
PP(pp_leavetry)
{
- djSP;
+ dSP;
register SV **mark;
SV **newsp;
PMOP *newpm;
STRLEN len;
register char *s = SvPV_force(sv, len);
register char *send = s + len;
- register char *base;
+ register char *base = Nullch;
register I32 skipspaces = 0;
- bool noblank;
- bool repeat;
+ bool noblank = FALSE;
+ bool repeat = FALSE;
bool postspace = FALSE;
U16 *fops;
register U16 *fpc;
- U16 *linepc;
+ U16 *linepc = 0;
register I32 arg;
bool ischop;
}
Copy(fops, s, arg, U16);
Safefree(fops);
- sv_magic(sv, Nullsv, 'f', Nullch, 0);
+ sv_magic(sv, Nullsv, PERL_MAGIC_fm, Nullch, 0);
SvCOMPILED_on(sv);
}
}
if (filter_sub && len >= 0) {
- djSP;
+ dSP;
int count;
ENTER;
https://perl5.git.perl.org / perl5.git / blobdiff