}
croak("Can't use global %s in \"my\"",name);
}
- if (AvFILL(comppad_name) >= 0) {
+ if (dowarn && AvFILL(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) {
if ((sv = svp[off])
pad_reset_pending = FALSE;
}
+#ifdef USE_THREADS
+/* find_thread_magical is not reentrant */
+PADOFFSET
+find_thread_magical(name)
+char *name;
+{
+ dTHR;
+ char *p;
+ PADOFFSET key;
+ SV **svp;
+ /* We currently only handle single character magicals */
+ p = strchr(per_thread_magicals, *name);
+ if (!p)
+ return NOT_IN_PAD;
+ key = p - per_thread_magicals;
+ svp = av_fetch(thr->magicals, key, FALSE);
+ if (!svp) {
+ SV *sv = NEWSV(0, 0);
+ av_store(thr->magicals, key, sv);
+ /*
+ * Some magic variables used to be automagically initialised
+ * in gv_fetchpv. Those which are now per-thread magicals get
+ * initialised here instead.
+ */
+ switch (*name) {
+ case ';':
+ sv_setpv(sv, "\034");
+ break;
+ }
+ sv_magic(sv, 0, 0, name, 1);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "find_thread_magical: new SV %p for $%s%c\n",
+ sv, (*name < 32) ? "^" : "",
+ (*name < 32) ? toCTRL(*name) : *name));
+ }
+ return key;
+}
+#endif /* USE_THREADS */
+
/* Destructor */
void
case OP_ENTEREVAL:
o->op_targ = 0; /* Was holding hints. */
break;
+#ifdef USE_THREADS
+ case OP_SPECIFIC:
+ o->op_targ = 0; /* Was holding index into thr->magicals AV. */
+ break;
+#endif /* USE_THREADS */
default:
if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst))
break;
{
if (dowarn &&
o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
+ dTHR;
line_t oldline = curcop->cop_line;
if (copline != NOLINE)
else
scalar(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_SCOPE:
case OP_LINESEQ:
else
scalar(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
}
return o;
case OP_NEXTSTATE:
case OP_DBSTATE:
- curcop = ((COP*)o); /* for warning below */
+ WITH_THR(curcop = ((COP*)o)); /* for warning below */
break;
case OP_CONST:
case OP_NULL:
if (o->op_targ == OP_NEXTSTATE || o->op_targ == OP_DBSTATE)
- curcop = ((COP*)o); /* for warning below */
+ WITH_THR(curcop = ((COP*)o)); /* for warning below */
if (o->op_flags & OPf_STACKED)
break;
/* FALL THROUGH */
else
list(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_SCOPE:
case OP_LINESEQ:
else
list(kid);
}
- curcop = &compiling;
+ WITH_THR(curcop = &compiling);
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
o->op_type == OP_LEAVE ||
o->op_type == OP_LEAVETRY)
{
+ dTHR;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
if (kid->op_sibling) {
scalarvoid(kid);
switch (o->op_type) {
case OP_UNDEF:
+ modcount++;
return o;
case OP_CONST:
if (!(o->op_private & (OPpCONST_ARYBASE)))
case OP_RV2AV:
case OP_RV2HV:
+ if (!type && cUNOPo->op_first->op_type != OP_GV)
+ croak("Can't localize through a reference");
if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
modcount = 10000;
return o; /* Treat \(@foo) like ordinary list. */
break;
case OP_RV2SV:
if (!type && cUNOPo->op_first->op_type != OP_GV)
- croak("Can't localize a reference");
+ croak("Can't localize through a reference");
ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
case OP_GV:
SvPV(*av_fetch(comppad_name, o->op_targ, 4), na));
break;
+#ifdef USE_THREADS
+ case OP_SPECIFIC:
+ modcount++; /* XXX ??? */
+#if 0
+ if (!type)
+ croak("Can't localize thread-specific variable");
+#endif
+ break;
+#endif /* USE_THREADS */
+
case OP_PUSHMARK:
break;
switch (o->op_type) {
case OP_ENTERSUB:
- if ((type == OP_DEFINED) &&
+ if ((type == OP_DEFINED || type == OP_LOCK) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = ppaddr[OP_RV2CV];
}
break;
+ case OP_SPECIFIC:
+ o->op_flags |= OPf_MOD; /* XXX ??? */
+ break;
+
case OP_RV2AV:
case OP_RV2HV:
o->op_flags |= OPf_REF;
OP *o;
{
if (o) {
- if (o->op_flags & OPf_PARENS || perldb || tainting) {
+ if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || tainting) {
o = prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o);
o->op_type = OP_LEAVE;
o->op_ppaddr = ppaddr[OP_LEAVE];
compcv = 0;
/* Register with debugger */
- if (perldb) {
+ if (PERLDB_INTER) {
CV *cv = perl_get_cv("DB::postponed", FALSE);
if (cv) {
dSP;
OP *o;
{
if (o->op_type == OP_LIST) {
- o = convert(OP_JOIN, 0,
- prepend_elem(OP_LIST,
- newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
- o));
+ OP *o2;
+#ifdef USE_THREADS
+ o2 = newOP(OP_SPECIFIC, 0);
+ o2->op_targ = find_thread_magical(";");
+#else
+ o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
+#endif /* USE_THREADS */
+ o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
}
if (!(opargs[type] & OA_FOLDCONST))
goto nope;
+ switch (type) {
+ case OP_SPRINTF:
+ case OP_UCFIRST:
+ case OP_LCFIRST:
+ case OP_UC:
+ case OP_LC:
+ if (o->op_private & OPpLOCALE)
+ goto nope;
+ }
+
if (error_count)
goto nope; /* Don't try to run w/ errors */
if (o->op_type == OP_TRANS)
return pmtrans(o, expr, repl);
+ hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)o;
if (expr->op_type == OP_CONST) {
OP *curop;
if (pm->op_pmflags & PMf_EVAL)
curop = 0;
+#ifdef USE_THREADS
+ else if (repl->op_type == OP_SPECIFIC
+ && strchr("&`'123456789+",
+ per_thread_magicals[repl->op_targ]))
+ {
+ curop = 0;
+ }
+#endif /* USE_THREADS */
else if (repl->op_type == OP_CONST)
curop = repl;
else {
OP *lastop = 0;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (opargs[curop->op_type] & OA_DANGEROUS) {
+#ifdef USE_THREADS
+ if (curop->op_type == OP_SPECIFIC
+ && strchr("&`'123456789+", curop->op_private)) {
+ break;
+ }
+#else
if (curop->op_type == OP_GV) {
GV *gv = ((GVOP*)curop)->op_gv;
if (strchr("&`'123456789+", *GvENAME(gv)))
break;
}
+#endif /* USE_THREADS */
else if (curop->op_type == OP_RV2CV)
break;
else if (curop->op_type == OP_RV2SV ||
register COP *cop;
Newz(1101, cop, 1, COP);
- if (perldb && curcop->cop_line && curstash != debstash) {
+ if (PERLDB_LINE && curcop->cop_line && curstash != debstash) {
cop->op_type = OP_DBSTATE;
cop->op_ppaddr = ppaddr[ OP_DBSTATE ];
}
cop->cop_filegv = (GV*)SvREFCNT_inc(curcop->cop_filegv);
cop->cop_stash = curstash;
- if (perldb && curstash != debstash) {
+ if (PERLDB_LINE && curstash != debstash) {
SV **svp = av_fetch(GvAV(curcop->cop_filegv),(I32)cop->cop_line, FALSE);
if (svp && *svp != &sv_undef && !SvIOK(*svp)) {
(void)SvIOK_on(*svp);
if (expr) {
if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
return block; /* do {} while 0 does once */
- if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB) {
+ if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) );
}
}
OP *
-newWHILEOP(flags, debuggable, loop, expr, block, cont)
+newWHILEOP(flags, debuggable, loop, whileline, expr, block, cont)
I32 flags;
I32 debuggable;
LOOP *loop;
+I32 whileline;
OP *expr;
OP *block;
OP *cont;
OP *o;
OP *condop;
- if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB)) {
+ if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ || (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB))) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newSVREF(newGVOP(OP_GV, 0, defgv)), 0, expr) );
}
if (cont)
next = LINKLIST(cont);
- if (expr)
+ if (expr) {
cont = append_elem(OP_LINESEQ, cont, newOP(OP_UNSTACK, 0));
+ if ((line_t)whileline != NOLINE) {
+ copline = whileline;
+ cont = append_elem(OP_LINESEQ, cont,
+ newSTATEOP(0, Nullch, Nullop));
+ }
+ }
listop = append_list(OP_LINESEQ, (LISTOP*)block, (LISTOP*)cont);
redo = LINKLIST(listop);
#endif /* CAN_PROTOTYPE */
{
LOOP *loop;
+ OP *wop;
int padoff = 0;
I32 iterflags = 0;
- copline = forline;
if (sv) {
if (sv->op_type == OP_RV2SV) { /* symbol table variable */
sv->op_type = OP_RV2GV;
assert(!loop->op_next);
Renew(loop, 1, LOOP);
loop->op_targ = padoff;
- return newSTATEOP(0, label, newWHILEOP(flags, 1, loop,
- newOP(OP_ITER, 0), block, cont));
+ wop = newWHILEOP(flags, 1, loop, forline, newOP(OP_ITER, 0), block, cont);
+ copline = forline;
+ return newSTATEOP(0, label, wop);
}
OP*
Safefree(CvMUTEXP(cv));
CvMUTEXP(cv) = 0;
}
- if (CvCONDP(cv)) {
- COND_DESTROY(CvCONDP(cv));
- Safefree(CvCONDP(cv));
- CvCONDP(cv) = 0;
- }
#endif /* USE_THREADS */
if (!CvXSUB(cv) && CvROOT(cv)) {
SV** ppad;
I32 ix;
- PerlIO_printf(Perl_debug_log, "\tCV=0x%p (%s), OUTSIDE=0x%p (%s)\n",
+ PerlIO_printf(Perl_debug_log, "\tCV=0x%lx (%s), OUTSIDE=0x%lx (%s)\n",
cv,
(CvANON(cv) ? "ANON"
: (cv == main_cv) ? "MAIN"
for (ix = 1; ix <= AvFILL(pad_name); ix++) {
if (SvPOK(pname[ix]))
- PerlIO_printf(Perl_debug_log, "\t%4d. 0x%p (%s\"%s\" %ld-%ld)\n",
+ PerlIO_printf(Perl_debug_log, "\t%4d. 0x%lx (%s\"%s\" %ld-%ld)\n",
ix, ppad[ix],
SvFAKE(pname[ix]) ? "FAKE " : "",
SvPVX(pname[ix]),
#ifdef USE_THREADS
New(666, CvMUTEXP(cv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(cv));
- New(666, CvCONDP(cv), 1, perl_cond);
- COND_INIT(CvCONDP(cv));
CvOWNER(cv) = 0;
#endif /* USE_THREADS */
CvFILEGV(cv) = CvFILEGV(proto);
CvOWNER(cv) = 0;
New(666, CvMUTEXP(cv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(cv));
- New(666, CvCONDP(cv), 1, perl_cond);
- COND_INIT(CvCONDP(cv));
#endif /* USE_THREADS */
if (ps)
croak(not_safe);
else {
/* force display of errors found but not reported */
- sv_catpv(GvSV(errgv), not_safe);
- croak("%s", SvPVx(GvSV(errgv), na));
+ sv_catpv(errsv, not_safe);
+ croak("%s", SvPV(errsv, na));
}
}
}
if (name) {
char *s;
- if (perldb && curstash != debstash) {
+ if (PERLDB_SUBLINE && curstash != debstash) {
SV *sv = NEWSV(0,0);
SV *tmpstr = sv_newmortal();
static GV *db_postponed;
av_store(endav, 0, (SV *)cv);
GvCV(gv) = 0;
}
- else if (strEQ(s, "RESTART") && !error_count) {
- if (!restartav)
- restartav = newAV();
- av_push(restartav, SvREFCNT_inc(cv));
+ else if (strEQ(s, "INIT") && !error_count) {
+ if (!initav)
+ initav = newAV();
+ av_push(initav, SvREFCNT_inc(cv));
}
}
return cv;
}
-#ifdef DEPRECATED
-CV *
-newXSUB(name, ix, subaddr, filename)
-char *name;
-I32 ix;
-I32 (*subaddr)();
-char *filename;
-{
- CV* cv = newXS(name, (void(*)())subaddr, filename);
- CvOLDSTYLE_on(cv);
- CvXSUBANY(cv).any_i32 = ix;
- return cv;
-}
-#endif
-
CV *
newXS(name, subaddr, filename)
char *name;
#ifdef USE_THREADS
New(666, CvMUTEXP(cv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(cv));
- New(666, CvCONDP(cv), 1, perl_cond);
- COND_INIT(CvCONDP(cv));
CvOWNER(cv) = 0;
#endif /* USE_THREADS */
CvFILEGV(cv) = gv_fetchfile(filename);
av_store(endav, 0, (SV *)cv);
GvCV(gv) = 0;
}
- else if (strEQ(s, "RESTART")) {
- if (!restartav)
- restartav = newAV();
- av_push(restartav, (SV *)cv);
+ else if (strEQ(s, "INIT")) {
+ if (!initav)
+ initav = newAV();
+ av_push(initav, (SV *)cv);
}
}
else
o->op_ppaddr = ppaddr[OP_PADSV];
return o;
}
+ else if (o->op_type == OP_SPECIFIC)
+ return o;
return newUNOP(OP_RV2SV, 0, scalar(o));
}
if (cLISTOPo->op_first->op_type == OP_STUB) {
op_free(o);
o = newUNOP(type, OPf_SPECIAL,
- newGVOP(OP_GV, 0, gv_fetchpv("main'ARGV", TRUE, SVt_PVAV)));
+ newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
}
return ck_fun(o);
}
else {
op_free(o);
if (type == OP_FTTTY)
- return newGVOP(type, OPf_REF, gv_fetchpv("main'STDIN", TRUE,
+ return newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
SVt_PVIO));
else
return newUNOP(type, 0, newSVREF(newGVOP(OP_GV, 0, defgv)));
ck_glob(o)
OP *o;
{
- GV *gv = gv_fetchpv("glob", FALSE, SVt_PVCV);
+ GV *gv;
+
+ if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
+ append_elem(OP_GLOB, o, newSVREF(newGVOP(OP_GV, 0, defgv)));
+
+ if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
+ gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
if (gv && GvIMPORTED_CV(gv)) {
static int glob_index;
append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0, gv)))));
- return ck_subr(o);
+ o = newUNOP(OP_NULL, 0, ck_subr(o));
+ o->op_targ = OP_GLOB; /* hint at what it used to be */
+ return o;
}
- if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
- append_elem(OP_GLOB, o, newSVREF(newGVOP(OP_GV, 0, defgv)));
gv = newGVgen("main");
gv_IOadd(gv);
append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
}
}
o->op_private |= (hints & HINT_STRICT_REFS);
- if (perldb && curstash != debstash)
+ if (PERLDB_SUB && curstash != debstash)
o->op_private |= OPpENTERSUB_DB;
while (o2 != cvop) {
if (proto) {
prev = o2;
o2 = o2->op_sibling;
}
- if (proto && !optional && *proto == '$')
+ if (proto && !optional &&
+ (*proto && *proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
return o;
}
o->op_seq = op_seqmax++;
break;
+ case OP_PADAV:
+ if (o->op_next->op_type == OP_RV2AV
+ && (o->op_next->op_flags && OPf_REF))
+ {
+ null(o->op_next);
+ o->op_next = o->op_next->op_next;
+ }
+ break;
+
+ case OP_PADHV:
+ if (o->op_next->op_type == OP_RV2HV
+ && (o->op_next->op_flags && OPf_REF))
+ {
+ null(o->op_next);
+ o->op_next = o->op_next->op_next;
+ }
+ break;
+
case OP_MAPWHILE:
case OP_GREPWHILE:
case OP_AND:
projects / p5sagit/p5-mst-13.2.git / blobdiff