S_no_fh_allowed(pTHX_ OP *o)
{
yyerror(Perl_form(aTHX_ "Missing comma after first argument to %s function",
- PL_op_desc[o->op_type]));
+ OP_DESC(o)));
return o;
}
S_bad_type(pTHX_ I32 n, char *t, char *name, OP *kid)
{
yyerror(Perl_form(aTHX_ "Type of arg %d to %s must be %s (not %s)",
- (int)n, name, t, PL_op_desc[kid->op_type]));
+ (int)n, name, t, OP_DESC(kid)));
}
STATIC void
PERL_CONTEXT *cx;
CV *outside;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
/*
* Special case to get lexical (and hence per-thread) @_.
* XXX I need to find out how to tell at parse-time whether use
*/
if (strEQ(name, "@_"))
return 0; /* success. (NOT_IN_PAD indicates failure) */
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
/* The one we're looking for is probably just before comppad_name_fill. */
for (off = AvFILLp(PL_comppad_name); off > 0; off--) {
}
SvFLAGS(sv) |= tmptype;
PL_curpad = AvARRAY(PL_comppad);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" Pad 0x%"UVxf" alloc %ld for %s\n",
PTR2UV(thr), PTR2UV(PL_curpad),
"Pad 0x%"UVxf" alloc %ld for %s\n",
PTR2UV(PL_curpad),
(long) retval, PL_op_name[optype]));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
return (PADOFFSET)retval;
}
SV *
Perl_pad_sv(pTHX_ PADOFFSET po)
{
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" Pad 0x%"UVxf" sv %"IVdf"\n",
PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
Perl_croak(aTHX_ "panic: pad_sv po");
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" sv %"IVdf"\n",
PTR2UV(PL_curpad), (IV)po));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
return PL_curpad[po]; /* eventually we'll turn this into a macro */
}
Perl_croak(aTHX_ "panic: pad_free curpad");
if (!po)
Perl_croak(aTHX_ "panic: pad_free po");
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" Pad 0x%"UVxf" free %"IVdf"\n",
PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
#else
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" free %"IVdf"\n",
PTR2UV(PL_curpad), (IV)po));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
SvPADTMP_off(PL_curpad[po]);
#ifdef USE_ITHREADS
Perl_croak(aTHX_ "panic: pad_swipe curpad");
if (!po)
Perl_croak(aTHX_ "panic: pad_swipe po");
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" Pad 0x%"UVxf" swipe %"IVdf"\n",
PTR2UV(thr), PTR2UV(PL_curpad), (IV)po));
#else
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" swipe %"IVdf"\n",
PTR2UV(PL_curpad), (IV)po));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
SvPADTMP_off(PL_curpad[po]);
PL_curpad[po] = NEWSV(1107,0);
SvPADTMP_on(PL_curpad[po]);
if (AvARRAY(PL_comppad) != PL_curpad)
Perl_croak(aTHX_ "panic: pad_reset curpad");
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
DEBUG_X(PerlIO_printf(Perl_debug_log,
"0x%"UVxf" Pad 0x%"UVxf" reset\n",
PTR2UV(thr), PTR2UV(PL_curpad)));
#else
DEBUG_X(PerlIO_printf(Perl_debug_log, "Pad 0x%"UVxf" reset\n",
PTR2UV(PL_curpad)));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */
for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) {
if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po]))
PL_pad_reset_pending = FALSE;
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
/* find_threadsv is not reentrant */
PADOFFSET
Perl_find_threadsv(pTHX_ const char *name)
}
return key;
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
/* Destructor */
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
case OP_ENTEREVAL: /* Was holding hints. */
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
case OP_THREADSV: /* Was holding index into thr->threadsv AV. */
#endif
o->op_targ = 0;
break;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
case OP_ENTERITER:
if (!(o->op_flags & OPf_SPECIAL))
break;
/* FALL THROUGH */
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
default:
if (!(o->op_flags & OPf_REF)
|| (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)))
#ifdef USE_ITHREADS
if(PL_regex_pad) { /* We could be in destruction */
av_push((AV*) PL_regex_pad[0],(SV*) PL_regex_pad[(cPMOPo)->op_pmoffset]);
+ SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
}
#endif
case OP_GETLOGIN:
func_ops:
if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
- useless = PL_op_desc[o->op_type];
+ useless = OP_DESC(o);
break;
case OP_RV2GV:
? "do block"
: (o->op_type == OP_ENTERSUB
? "non-lvalue subroutine call"
- : PL_op_desc[o->op_type])),
+ : OP_DESC(o))),
type ? PL_op_desc[type] : "local"));
return o;
SvPV(*av_fetch(PL_comppad_name, o->op_targ, 4), n_a));
break;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
case OP_THREADSV:
PL_modcount++; /* XXX ??? */
break;
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
case OP_PUSHMARK:
break;
type != OP_PUSHMARK)
{
yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
- PL_op_desc[o->op_type],
+ OP_DESC(o),
PL_in_my == KEY_our ? "our" : "my"));
return o;
}
STATIC OP *
S_newDEFSVOP(pTHX)
{
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
OP *o = newOP(OP_THREADSV, 0);
o->op_targ = find_threadsv("_");
return o;
#else
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
}
void
{
if (o->op_type == OP_LIST) {
OP *o2;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
o2 = newOP(OP_THREADSV, 0);
o2->op_targ = find_threadsv(";");
#else
o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
if(av_len((AV*) PL_regex_pad[0]) > -1) {
repointer = av_pop((AV*)PL_regex_pad[0]);
pmop->op_pmoffset = SvIV(repointer);
+ SvREPADTMP_off(repointer);
sv_setiv(repointer,0);
} else {
repointer = newSViv(0);
if (CopLINE(PL_curcop) < PL_multi_end)
CopLINE_set(PL_curcop, PL_multi_end);
}
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
else if (repl->op_type == OP_THREADSV
&& strchr("&`'123456789+",
PL_threadsv_names[repl->op_targ]))
{
curop = 0;
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
else if (repl->op_type == OP_CONST)
curop = repl;
else {
OP *lastop = 0;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (curop->op_type == OP_THREADSV) {
repl_has_vars = 1;
if (strchr("&`'123456789+", curop->op_private))
if (strchr("&`'123456789+", *GvENAME(gv)))
break;
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
else if (curop->op_type == OP_RV2CV)
break;
else if (curop->op_type == OP_RV2SV ||
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
}
else {
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
padoff = find_threadsv("_");
iterflags |= OPf_SPECIAL;
#else
void
Perl_cv_undef(pTHX_ CV *cv)
{
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (CvMUTEXP(cv)) {
MUTEX_DESTROY(CvMUTEXP(cv));
Safefree(CvMUTEXP(cv));
CvMUTEXP(cv) = 0;
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
#ifdef USE_ITHREADS
if (CvFILE(cv) && !CvXSUB(cv)) {
#endif
if (!CvXSUB(cv) && CvROOT(cv)) {
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (CvDEPTH(cv) || (CvOWNER(cv) && CvOWNER(cv) != thr))
Perl_croak(aTHX_ "Can't undef active subroutine");
#else
if (CvDEPTH(cv))
Perl_croak(aTHX_ "Can't undef active subroutine");
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
ENTER;
SAVEVPTR(PL_curpad);
CvFLAGS(cv) = CvFLAGS(proto) & ~CVf_CLONE;
CvCLONED_on(cv);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
New(666, CvMUTEXP(cv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(cv));
CvOWNER(cv) = 0;
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
#ifdef USE_ITHREADS
CvFILE(cv) = CvXSUB(proto) ? CvFILE(proto)
: savepv(CvFILE(proto));
CvGV(cv) = gv;
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH(cv) = PL_curstash;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
CvOWNER(cv) = 0;
if (!CvMUTEXP(cv)) {
New(666, CvMUTEXP(cv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(cv));
}
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
if (ps)
sv_setpv((SV*)cv, ps);
}
}
CvGV(cv) = gv;
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
New(666, CvMUTEXP(cv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(cv));
CvOWNER(cv) = 0;
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
(void)gv_fetchfile(filename);
CvFILE(cv) = filename; /* NOTE: not copied, as it is expected to be
an external constant string */
break;
default:
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
- PL_op_desc[o->op_type]);
+ OP_DESC(o));
}
op_null(kid);
}
(void) ref(kid, o->op_type);
if (kid->op_type != OP_RV2CV && !PL_error_count)
Perl_croak(aTHX_ "%s argument is not a subroutine name",
- PL_op_desc[o->op_type]);
+ OP_DESC(o));
o->op_private |= OPpEXISTS_SUB;
}
else if (kid->op_type == OP_AELEM)
o->op_flags |= OPf_SPECIAL;
else if (kid->op_type != OP_HELEM)
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
- PL_op_desc[o->op_type]);
+ OP_DESC(o));
op_null(kid);
}
return o;
}
else if (kid->op_type == OP_READLINE) {
/* neophyte patrol: open(<FH>), close(<FH>) etc. */
- bad_type(numargs, "HANDLE", PL_op_desc[o->op_type], kid);
+ bad_type(numargs, "HANDLE", OP_DESC(o), kid);
}
else {
I32 flags = OPf_SPECIAL;
}
o->op_private |= numargs;
if (kid)
- return too_many_arguments(o,PL_op_desc[o->op_type]);
+ return too_many_arguments(o,OP_DESC(o));
listkids(o);
}
else if (PL_opargs[type] & OA_DEFGV) {
while (oa & OA_OPTIONAL)
oa >>= 4;
if (oa && oa != OA_LIST)
- return too_few_arguments(o,PL_op_desc[o->op_type]);
+ return too_few_arguments(o,OP_DESC(o));
}
return o;
}
kid = cLISTOPo->op_first->op_sibling;
if (!kid || !kid->op_sibling)
- return too_few_arguments(o,PL_op_desc[o->op_type]);
+ return too_few_arguments(o,OP_DESC(o));
for (kid = kid->op_sibling; kid; kid = kid->op_sibling)
mod(kid, OP_GREPSTART);
OP *argop;
op_free(o);
-#ifdef USE_THREADS
+#ifdef USE_5005THREADS
if (!CvUNIQUE(PL_compcv)) {
argop = newOP(OP_PADAV, OPf_REF);
argop->op_targ = 0; /* PL_curpad[0] is @_ */
argop = newUNOP(OP_RV2AV, 0,
scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
-#endif /* USE_THREADS */
+#endif /* USE_5005THREADS */
return newUNOP(type, 0, scalar(argop));
}
return scalar(modkids(ck_fun(o), type));
scalar(kid);
if (kid->op_sibling)
- return too_many_arguments(o,PL_op_desc[o->op_type]);
+ return too_many_arguments(o,OP_DESC(o));
return o;
}
LEAVE;
}
+#ifdef PERL_CUSTOM_OPS
+char* custom_op_name(pTHX_ OP* o)
+{
+ IV index = PTR2IV(o->op_ppaddr);
+ SV* keysv;
+ HE* he;
+
+ if (!PL_custom_op_names) /* This probably shouldn't happen */
+ return PL_op_name[OP_CUSTOM];
+
+ keysv = sv_2mortal(newSViv(index));
+
+ he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
+ if (!he)
+ return PL_op_name[OP_CUSTOM]; /* Don't know who you are */
+
+ return SvPV_nolen(HeVAL(he));
+}
+
+char* custom_op_desc(pTHX_ OP* o)
+{
+ IV index = PTR2IV(o->op_ppaddr);
+ SV* keysv;
+ HE* he;
+
+ if (!PL_custom_op_descs)
+ return PL_op_desc[OP_CUSTOM];
+
+ keysv = sv_2mortal(newSViv(index));
+
+ he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
+ if (!he)
+ return PL_op_desc[OP_CUSTOM];
+
+ return SvPV_nolen(HeVAL(he));
+}
+#endif
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */