#include "perl.h"
#include "keywords.h"
+#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
+
/* #define PL_OP_SLAB_ALLOC */
-#ifdef PL_OP_SLAB_ALLOC
+#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
#define SLAB_SIZE 8192
-static char *PL_OpPtr = NULL;
-static int PL_OpSpace = 0;
+static char *PL_OpPtr = NULL; /* XXX threadead */
+static int PL_OpSpace = 0; /* XXX threadead */
#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
var = (type *)(PL_OpPtr -= c*sizeof(type)); \
else \
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
if (!(PL_in_my == KEY_our ||
isALPHA(name[1]) ||
- (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
+ (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
(name[1] == '_' && (int)strlen(name) > 2)))
{
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
cv = cx->blk_sub.cv;
if (PL_debstash && CvSTASH(cv) == PL_debstash) { /* ignore DB'* scope */
saweval = i; /* so we know where we were called from */
+ seq = cxstack[i].blk_oldcop->cop_seq;
continue;
}
return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
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 */
void
Perl_op_clear(pTHX_ OP *o)
{
+
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)))
goto clear_pmop;
case OP_PUSHRE:
#ifdef USE_ITHREADS
- if ((PADOFFSET)cPMOPo->op_pmreplroot) {
+ if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
if (PL_curpad) {
- GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
- pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
+ GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
+ pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
/* No GvIN_PAD_off(gv) here, because other references may still
* exist on the pad */
SvREFCNT_dec(gv);
lastpmop = pmop;
pmop = pmop->op_pmnext;
}
+ }
#ifdef USE_ITHREADS
- Safefree(PmopSTASHPV(cPMOPo));
+ Safefree(PmopSTASHPV(cPMOPo));
#else
- /* NOTE: PMOP.op_pmstash is not refcounted */
+ /* NOTE: PMOP.op_pmstash is not refcounted */
#endif
- }
}
cPMOPo->op_pmreplroot = Nullop;
- ReREFCNT_dec(cPMOPo->op_pmregexp);
- cPMOPo->op_pmregexp = (REGEXP*)NULL;
+ /* we use the "SAFE" version of the PM_ macros here
+ * since sv_clean_all might release some PMOPs
+ * after PL_regex_padav has been cleared
+ * and the clearing of PL_regex_padav needs to
+ * happen before sv_clean_all
+ */
+ ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
+ PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
+#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
+
break;
}
}
WITH_THR(PL_curcop = &PL_compiling);
break;
+ case OP_SORT:
+ if (ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
}
return o;
}
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:
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
+ else if (o->op_private & OPpENTERSUB_NOMOD)
+ return o;
else { /* lvalue subroutine call */
o->op_private |= OPpLVAL_INTRO;
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
- "args: type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "args: type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
kid = kLISTOP->op_first;
skip_kids:
while (kid->op_sibling)
|| kid->op_type == OP_METHOD)
{
UNOP *newop;
-
- if (kid->op_sibling || kid->op_next != kid) {
- yyerror("panic: unexpected optree near method call");
- break;
- }
NewOp(1101, newop, 1, UNOP);
newop->op_type = OP_RV2CV;
if (kid->op_type != OP_RV2CV)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
- "entry via type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "entry via type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
kid->op_private |= OPpLVAL_INTRO;
break; /* Postpone until runtime */
}
if (kid->op_type == OP_NULL)
Perl_croak(aTHX_
"Unexpected constant lvalue entersub "
- "entry via type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "entry via type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
if (kid->op_type != OP_GV) {
/* Restore RV2CV to check lvalueness */
restore_2cv:
? "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;
goto nomod;
break; /* mod()ing was handled by ck_return() */
}
+
+ /* [20011101.069] File test operators interpret OPf_REF to mean that
+ their argument is a filehandle; thus \stat(".") should not set
+ it. AMS 20011102 */
+ if (type == OP_REFGEN &&
+ PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
+ return o;
+
if (type != OP_LEAVESUBLV)
o->op_flags |= OPf_MOD;
}
STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
{
SV *stashsv;
/* fake up C<use attributes $pkg,$rv,@attrs> */
ENTER; /* need to protect against side-effects of 'use' */
SAVEINT(PL_expect);
- if (stash && HvNAME(stash))
+ if (stash)
stashsv = newSVpv(HvNAME(stash), 0);
else
stashsv = &PL_sv_no;
#define ATTRSMODULE "attributes"
+#define ATTRSMODULE_PM "attributes.pm"
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv,
- prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, stashsv),
- prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0,
- newRV(target)),
- dup_attrlist(attrs))));
+ if (for_my) {
+ SV **svp;
+ /* Don't force the C<use> if we don't need it. */
+ svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
+ sizeof(ATTRSMODULE_PM)-1, 0);
+ if (svp && *svp != &PL_sv_undef)
+ ; /* already in %INC */
+ else
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ Nullsv);
+ }
+ else {
+ Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ Nullsv,
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newRV(target)),
+ dup_attrlist(attrs))));
+ }
LEAVE;
}
+STATIC void
+S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
+{
+ OP *pack, *imop, *arg;
+ SV *meth, *stashsv;
+
+ if (!attrs)
+ return;
+
+ assert(target->op_type == OP_PADSV ||
+ target->op_type == OP_PADHV ||
+ target->op_type == OP_PADAV);
+
+ /* Ensure that attributes.pm is loaded. */
+ apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
+
+ /* Need package name for method call. */
+ pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
+
+ /* Build up the real arg-list. */
+ if (stash)
+ stashsv = newSVpv(HvNAME(stash), 0);
+ else
+ stashsv = &PL_sv_no;
+ arg = newOP(OP_PADSV, 0);
+ arg->op_targ = target->op_targ;
+ arg = prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ prepend_elem(OP_LIST,
+ newUNOP(OP_REFGEN, 0,
+ mod(arg, OP_REFGEN)),
+ dup_attrlist(attrs)));
+
+ /* Fake up a method call to import */
+ meth = newSVpvn("import", 6);
+ (void)SvUPGRADE(meth, SVt_PVIV);
+ (void)SvIOK_on(meth);
+ PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, pack, list(arg)),
+ newSVOP(OP_METHOD_NAMED, 0, meth)));
+ imop->op_private |= OPpENTERSUB_NOMOD;
+
+ /* Combine the ops. */
+ *imopsp = append_elem(OP_LIST, *imopsp, imop);
+}
+
+/*
+=notfor apidoc apply_attrs_string
+
+Attempts to apply a list of attributes specified by the C<attrstr> and
+C<len> arguments to the subroutine identified by the C<cv> argument which
+is expected to be associated with the package identified by the C<stashpv>
+argument (see L<attributes>). It gets this wrong, though, in that it
+does not correctly identify the boundaries of the individual attribute
+specifications within C<attrstr>. This is not really intended for the
+public API, but has to be listed here for systems such as AIX which
+need an explicit export list for symbols. (It's called from XS code
+in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
+to respect attribute syntax properly would be welcome.
+
+=cut
+*/
+
void
Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
char *attrstr, STRLEN len)
}
STATIC OP *
-S_my_kid(pTHX_ OP *o, OP *attrs)
+S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
OP *kid;
I32 type;
type = o->op_type;
if (type == OP_LIST) {
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- my_kid(kid, attrs);
+ my_kid(kid, attrs, imopsp);
} else if (type == OP_UNDEF) {
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? (SV*)GvAV(gv) :
type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
- attrs);
+ attrs, FALSE);
}
o->op_private |= OPpOUR_INTRO;
return o;
- } else if (type != OP_PADSV &&
+ }
+ else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
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;
}
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
- SV *padsv;
SV **namesvp;
PL_in_my = FALSE;
/* check for C<my Dog $spot> when deciding package */
namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
- if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED)
- && HvNAME(SvSTASH(*namesvp)))
+ if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED))
stash = SvSTASH(*namesvp);
else
stash = PL_curstash;
- padsv = PAD_SV(o->op_targ);
- apply_attrs(stash, padsv, attrs);
+ apply_attrs_my(stash, o, attrs, imopsp);
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
+ OP *rops = Nullop;
+ int maybe_scalar = 0;
+
if (o->op_flags & OPf_PARENS)
list(o);
+ else
+ maybe_scalar = 1;
if (attrs)
SAVEFREEOP(attrs);
- o = my_kid(o, attrs);
+ o = my_kid(o, attrs, &rops);
+ if (rops) {
+ if (maybe_scalar && o->op_type == OP_PADSV) {
+ o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
+ o->op_private |= OPpLVAL_INTRO;
+ }
+ else
+ o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
+ }
PL_in_my = FALSE;
PL_in_my_stash = Nullhv;
return o;
OP *
Perl_my(pTHX_ OP *o)
{
- return my_kid(o, Nullop);
+ return my_attrs(o, Nullop);
}
OP *
desc, sample, sample);
}
+ if (right->op_type == OP_CONST &&
+ cSVOPx(right)->op_private & OPpCONST_BARE &&
+ cSVOPx(right)->op_private & OPpCONST_STRICT)
+ {
+ no_bareword_allowed(right);
+ }
+
if (!(right->op_flags & OPf_STACKED) &&
(right->op_type == OP_MATCH ||
right->op_type == OP_SUBST ||
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- OP* retval = scalarseq(seq);
+ line_t copline = PL_copline;
+ /* there should be a nextstate in every block */
+ OP* retval = seq ? scalarseq(seq) : newSTATEOP(0, Nullch, seq);
+ PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
LEAVE_SCOPE(floor);
PL_pad_reset_pending = FALSE;
PL_compiling.op_private = PL_hints;
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
PL_eval_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_eval_root, 1);
PL_eval_root->op_next = 0;
- peep(PL_eval_start);
+ CALL_PEEP(PL_eval_start);
}
else {
if (!o)
PL_main_root->op_private |= OPpREFCOUNTED;
OpREFCNT_set(PL_main_root, 1);
PL_main_root->op_next = 0;
- peep(PL_main_start);
+ CALL_PEEP(PL_main_start);
PL_compcv = 0;
/* Register with debugger */
if (o->op_flags & OPf_PARENS)
list(o);
else {
- if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
- char *s;
- for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
+ if (ckWARN(WARN_PARENTHESIS)
+ && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
+ {
+ char *s = PL_bufptr;
+
+ while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
+ s++;
+
if (*s == ';' || *s == '=')
Perl_warner(aTHX_ WARN_PARENTHESIS,
"Parentheses missing around \"%s\" list",
{
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;
PL_op = curop = LINKLIST(o);
o->op_next = 0;
- peep(curop);
+ CALL_PEEP(curop);
pp_pushmark();
CALLRUNOPS(aTHX);
PL_op = curop;
if (!squash)
o->op_private |= OPpTRANS_IDENTICAL;
}
+ else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
for (i = 0; i < 256; i++)
tbl[i] = -1;
for (i = 0, j = 0; i < tlen; i++,j++) {
pmop->op_pmpermflags |= PMf_LOCALE;
pmop->op_pmflags = pmop->op_pmpermflags;
- /* link into pm list */
+#ifdef USE_ITHREADS
+ {
+ SV* repointer;
+ 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);
+ av_push(PL_regex_padav,SvREFCNT_inc(repointer));
+ pmop->op_pmoffset = av_len(PL_regex_padav);
+ PL_regex_pad = AvARRAY(PL_regex_padav);
+ }
+ }
+#endif
+
+ /* link into pm list */
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
HvPMROOT(PL_curstash) = pmop;
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
- if ((PL_hints & HINT_UTF8) || DO_UTF8(pat))
- pm->op_pmdynflags |= PMdf_UTF8;
- pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
- if (strEQ("\\s+", pm->op_pmregexp->precomp))
+ PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
+ if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
op_free(expr);
}
else {
- if (PL_hints & HINT_UTF8)
- pm->op_pmdynflags |= PMdf_UTF8;
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
? OP_REGCRESET
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 ||
}
if (curop == repl
&& !(repl_has_vars
- && (!pm->op_pmregexp
- || pm->op_pmregexp->reganch & ROPT_EVAL_SEEN))) {
+ && (!PM_GETRE(pm)
+ || PM_GETRE(pm)->reganch & ROPT_EVAL_SEEN))) {
pm->op_pmflags |= PMf_CONST; /* const for long enough */
pm->op_pmpermflags |= PMf_CONST; /* const for long enough */
prepend_elem(o->op_type, scalar(repl), o);
}
else {
- if (curop == repl && !pm->op_pmregexp) { /* Has variables. */
+ if (curop == repl && !PM_GETRE(pm)) { /* Has variables. */
pm->op_pmflags |= PMf_MAYBE_CONST;
pm->op_pmpermflags |= PMf_MAYBE_CONST;
}
op_free(o);
}
else {
+ deprecate("\"package\" with no arguments");
sv_setpv(PL_curstname,"<none>");
PL_curstash = Nullhv;
}
OP *pack;
OP *imop;
OP *veop;
+ char *packname = Nullch;
+ STRLEN packlen = 0;
+ SV *packsv;
if (id->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
/* Fake up a method call to import/unimport */
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
- sv_upgrade(meth, SVt_PVIV);
+ (void)SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
newSVOP(OP_METHOD_NAMED, 0, meth)));
}
+ if (ckWARN(WARN_MISC) &&
+ imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
+ SvPOK(packsv = ((SVOP*)id)->op_sv))
+ {
+ /* BEGIN will free the ops, so we need to make a copy */
+ packlen = SvCUR(packsv);
+ packname = savepvn(SvPVX(packsv), packlen);
+ }
+
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
+ if (packname) {
+ if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
+ Perl_warner(aTHX_ WARN_MISC,
+ "Package `%s' not found "
+ "(did you use the incorrect case?)", packname);
+ }
+ safefree(packname);
+ }
+
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
GV *gv;
gv = gv_fetchpv("do", FALSE, SVt_PVCV);
- if (!(gv && GvIMPORTED_CV(gv)))
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
- if (gv && GvIMPORTED_CV(gv)) {
+ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
return FALSE;
}
+ if (o->op_type == OP_LIST &&
+ (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
+ o->op_private & OPpLVAL_INTRO)
+ return FALSE;
+
if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
else if (curop->op_type == OP_PUSHRE) {
if (((PMOP*)curop)->op_pmreplroot) {
#ifdef USE_ITHREADS
- GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
+ GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
#else
GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
#endif
tmpop = ((UNOP*)left)->op_first;
if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
+ pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
- (void)SvIOK_on(*svp);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
SvIVX(*svp) = PTR2IV(cop);
- }
+ }
}
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
OP *next = 0;
OP *listop;
OP *o;
- OP *condop;
U8 loopflags = 0;
if (expr && (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
return Nullop; /* listop already freed by new_logop */
}
if (listop)
- ((LISTOP*)listop)->op_last->op_next = condop =
+ ((LISTOP*)listop)->op_last->op_next =
(o == listop ? redo : LINKLIST(o));
}
else
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)) {
+ /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ Safefree(CvFILE(cv));
+ }
+ CvFILE(cv) = 0;
+#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);
* CV, they don't hold a refcount on the outside CV. This avoids
* the refcount loop between the outer CV (which keeps a refcount to
* the closure prototype in the pad entry for pp_anoncode()) and the
- * closure prototype, and the ensuing memory leak. This does not
- * apply to closures generated within eval"", since eval"" CVs are
- * ephemeral. --GSAR */
- if (!CvANON(cv) || CvCLONED(cv)
- || (CvOUTSIDE(cv) && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
- {
+ * closure prototype, and the ensuing memory leak. --GSAR */
+ if (!CvANON(cv) || CvCLONED(cv))
SvREFCNT_dec(CvOUTSIDE(cv));
- }
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
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));
+#else
CvFILE(cv) = CvFILE(proto);
+#endif
CvGV(cv) = CvGV(proto);
CvSTASH(cv) = CvSTASH(proto);
CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
}
}
-static void const_sv_xsub(pTHXo_ CV* cv);
+static void const_sv_xsub(pTHX_ CV* cv);
/*
=for apidoc cv_const_sv
cv = (!name || GvCVGEN(gv)) ? Nullcv : GvCV(gv);
-#ifdef GV_SHARED_CHECK
- if (cv && GvSHARED(gv) && SvREADONLY(cv)) {
- Perl_croak(aTHX_ "Can't define subroutine %s (GV is shared)", name);
+#ifdef GV_UNIQUE_CHECK
+ if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
+ Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
}
#endif
if (cv) {
bool exists = CvROOT(cv) || CvXSUB(cv);
-#ifdef GV_SHARED_CHECK
- if (exists && GvSHARED(gv)) {
- Perl_croak(aTHX_ "Can't redefine shared subroutine %s", name);
+#ifdef GV_UNIQUE_CHECK
+ if (exists && GvUNIQUE(gv)) {
+ Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
}
#endif
&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
{
line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ WARN_REDEFINE,
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined", name);
*/
if (cv && !block) {
rcv = (SV*)cv;
- if (CvGV(cv) && GvSTASH(CvGV(cv)) && HvNAME(GvSTASH(CvGV(cv))))
+ if (CvGV(cv) && GvSTASH(CvGV(cv)))
stash = GvSTASH(CvGV(cv));
- else if (CvSTASH(cv) && HvNAME(CvSTASH(cv)))
+ else if (CvSTASH(cv))
stash = CvSTASH(cv);
else
stash = PL_curstash;
else {
/* possibly about to re-define existing subr -- ignore old cv */
rcv = (SV*)PL_compcv;
- if (name && GvSTASH(gv) && HvNAME(GvSTASH(gv)))
+ if (name && GvSTASH(gv))
stash = GvSTASH(gv);
else
stash = PL_curstash;
}
- apply_attrs(stash, rcv, attrs);
+ apply_attrs(stash, rcv, attrs, FALSE);
}
if (cv) { /* must reuse cv if autoloaded */
if (!block) {
}
/* ... before we throw it away */
SvREFCNT_dec(PL_compcv);
+ if (PERLDB_INTER)/* Advice debugger on the new sub. */
+ ++PL_sub_generation;
}
else {
cv = PL_compcv;
}
}
CvGV(cv) = gv;
- CvFILE(cv) = CopFILE(PL_curcop);
+ 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);
OpREFCNT_set(CvROOT(cv), 1);
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
- peep(CvSTART(cv));
+ CALL_PEEP(CvSTART(cv));
/* now that optimizer has done its work, adjust pad values */
if (CvCLONE(cv)) {
}
}
- /* If a potential closure prototype, don't keep a refcount on
- * outer CV, unless the latter happens to be a passing eval"".
+ /* If a potential closure prototype, don't keep a refcount on outer CV.
* This is okay as the lifetime of the prototype is tied to the
* lifetime of the outer CV. Avoids memory leak due to reference
* loop. --GSAR */
- if (!name && CvOUTSIDE(cv)
- && !(CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
- {
+ if (!name)
SvREFCNT_dec(CvOUTSIDE(cv));
- }
if (name || aname) {
char *s;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
- save_svref(&PL_rs);
- sv_setsv(PL_rs, PL_nrs);
if (!PL_beginav)
PL_beginav = newAV();
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
- && HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
}
}
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 */
else
name = "STDOUT";
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
-#ifdef GV_SHARED_CHECK
- if (GvSHARED(gv)) {
- Perl_croak(aTHX_ "Bad symbol for form (GV is shared)");
+#ifdef GV_UNIQUE_CHECK
+ if (GvUNIQUE(gv)) {
+ Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
}
#endif
GvMULTI_on(gv);
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
line_t oldline = CopLINE(PL_curcop);
-
- CopLINE_set(PL_curcop, PL_copline);
+ if (PL_copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
CopLINE_set(PL_curcop, oldline);
}
cv = PL_compcv;
GvFORM(gv) = cv;
CvGV(cv) = gv;
- CvFILE(cv) = CopFILE(PL_curcop);
+ CvFILE_set_from_cop(cv, PL_curcop);
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
if (!SvPADMY(PL_curpad[ix]) && !SvIMMORTAL(PL_curpad[ix]))
OpREFCNT_set(CvROOT(cv), 1);
CvSTART(cv) = LINKLIST(CvROOT(cv));
CvROOT(cv)->op_next = 0;
- peep(CvSTART(cv));
+ CALL_PEEP(CvSTART(cv));
op_free(o);
PL_copline = NOLINE;
LEAVE_SCOPE(floor);
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);
}
}
OP *
+Perl_ck_die(pTHX_ OP *o)
+{
+#ifdef VMS
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
+#endif
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_eof(pTHX_ OP *o)
{
I32 type = o->op_type;
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
#endif
return ck_fun(o);
}
(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;
}
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
append_elem(OP_GLOB, o, newDEFSVOP());
- if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
+ if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
+ && GvCVu(gv) && GvIMPORTED_CV(gv)))
+ {
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+ }
#if !defined(PERL_EXTERNAL_GLOB)
/* XXX this can be tightened up and made more failsafe. */
}
#endif /* PERL_EXTERNAL_GLOB */
- if (gv && GvIMPORTED_CV(gv)) {
+ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
append_elem(OP_GLOB, o,
newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
o->op_type = OP_LIST;
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);
/* handle override, if any */
gv = gv_fetchpv("require", FALSE, SVt_PVCV);
- if (!(gv && GvIMPORTED_CV(gv)))
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
- if (gv && GvIMPORTED_CV(gv)) {
+ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
OP *kid = cUNOPo->op_first;
cUNOPo->op_first = 0;
op_free(o);
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));
kid->op_next = 0; /* just disconnect the leave */
k = kLISTOP->op_first;
}
- peep(k);
+ CALL_PEEP(k);
kid = firstkid;
if (o->op_type == OP_SORT) {
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;
}
OP *kid = cLISTOPo->op_first->op_sibling;
if (kid && kid->op_type == OP_MATCH) {
char *pmstr = "STRING";
- if (kPMOP->op_pmregexp)
- pmstr = kPMOP->op_pmregexp->precomp;
+ if (PM_GETRE(kPMOP))
+ pmstr = PM_GETRE(kPMOP)->precomp;
Perl_warner(aTHX_ WARN_SYNTAX,
"/%s/ should probably be written as \"%s\"",
pmstr, pmstr);
GV *namegv = 0;
int optional = 0;
I32 arg = 0;
+ I32 contextclass = 0;
+ char *e = 0;
STRLEN n_a;
o->op_private |= OPpENTERSUB_HASTARG;
}
scalar(o2);
break;
+ case '[': case ']':
+ goto oops;
+ break;
case '\\':
proto++;
arg++;
+ again:
switch (*proto++) {
+ case '[':
+ if (contextclass++ == 0) {
+ e = strchr(proto, ']');
+ if (!e || e == proto)
+ goto oops;
+ }
+ else
+ goto oops;
+ goto again;
+ break;
+ case ']':
+ if (contextclass)
+ contextclass = 0;
+ else
+ goto oops;
+ break;
case '*':
- if (o2->op_type != OP_RV2GV)
- bad_type(arg, "symbol", gv_ename(namegv), o2);
- goto wrapref;
+ if (o2->op_type == OP_RV2GV)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "symbol", gv_ename(namegv), o2);
+ break;
case '&':
- if (o2->op_type != OP_ENTERSUB)
- bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
- goto wrapref;
+ if (o2->op_type == OP_ENTERSUB)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "subroutine entry", gv_ename(namegv), o2);
+ break;
case '$':
- if (o2->op_type != OP_RV2SV
- && o2->op_type != OP_PADSV
- && o2->op_type != OP_HELEM
- && o2->op_type != OP_AELEM
- && o2->op_type != OP_THREADSV)
- {
+ if (o2->op_type == OP_RV2SV ||
+ o2->op_type == OP_PADSV ||
+ o2->op_type == OP_HELEM ||
+ o2->op_type == OP_AELEM ||
+ o2->op_type == OP_THREADSV)
+ goto wrapref;
+ if (!contextclass)
bad_type(arg, "scalar", gv_ename(namegv), o2);
- }
- goto wrapref;
+ break;
case '@':
- if (o2->op_type != OP_RV2AV && o2->op_type != OP_PADAV)
+ if (o2->op_type == OP_RV2AV ||
+ o2->op_type == OP_PADAV)
+ goto wrapref;
+ if (!contextclass)
bad_type(arg, "array", gv_ename(namegv), o2);
- goto wrapref;
+ break;
case '%':
- if (o2->op_type != OP_RV2HV && o2->op_type != OP_PADHV)
- bad_type(arg, "hash", gv_ename(namegv), o2);
- wrapref:
+ if (o2->op_type == OP_RV2HV ||
+ o2->op_type == OP_PADHV)
+ goto wrapref;
+ if (!contextclass)
+ bad_type(arg, "hash", gv_ename(namegv), o2);
+ break;
+ wrapref:
{
OP* kid = o2;
OP* sib = kid->op_sibling;
o2->op_sibling = sib;
prev->op_sibling = o2;
}
+ if (contextclass && e) {
+ proto = e + 1;
+ contextclass = 0;
+ }
break;
default: goto oops;
}
+ if (contextclass)
+ goto again;
break;
case ' ':
proto++;
default:
oops:
Perl_croak(aTHX_ "Malformed prototype for %s: %s",
- gv_ename(namegv), SvPV((SV*)cv, n_a));
+ gv_ename(namegv), SvPV((SV*)cv, n_a));
}
}
else
{
PL_curcop = ((COP*)o);
}
- goto nothin;
+ /* XXX: We avoid setting op_seq here to prevent later calls
+ to peep() from mistakenly concluding that optimisation
+ has already occurred. This doesn't fix the real problem,
+ though (See 20010220.007). AMS 20010719 */
+ if (oldop && o->op_next) {
+ oldop->op_next = o->op_next;
+ continue;
+ }
+ break;
case OP_SCALAR:
case OP_LINESEQ:
case OP_SCOPE:
SvPV_nolen(sv));
}
}
+ else if (o->op_next->op_type == OP_READLINE
+ && o->op_next->op_next->op_type == OP_CONCAT
+ && (o->op_next->op_next->op_flags & OPf_STACKED))
+ {
+ /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
+ o->op_type = OP_RCATLINE;
+ o->op_flags |= OPf_STACKED;
+ o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
+ op_null(o->op_next->op_next);
+ op_null(o->op_next);
+ }
o->op_seq = PL_op_seqmax++;
break;
o->op_seq = PL_op_seqmax++;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- peep(cLOGOP->op_other);
+ peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
break;
case OP_ENTERLOOP:
svp = cSVOPx_svp(((BINOP*)o)->op_last);
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
key = SvPV(sv, keylen);
- if (SvUTF8(sv))
- keylen = -keylen;
- lexname = newSVpvn_share(key, keylen, 0);
+ lexname = newSVpvn_share(key,
+ SvUTF8(sv) ? -(I32)keylen : keylen,
+ 0);
SvREFCNT_dec(sv);
*svp = lexname;
}
if (!fields || !GvHV(*fields))
break;
key = SvPV(*svp, keylen);
- if (SvUTF8(*svp))
- keylen = -keylen;
- indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
+ indsvp = hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
key_op = (SVOP*)key_op->op_sibling) {
svp = cSVOPx_svp(key_op);
key = SvPV(*svp, keylen);
- if (SvUTF8(*svp))
- keylen = -keylen;
- indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
+ indsvp = hv_fetch(GvHV(*fields), key,
+ SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
"in variable %s of type %s",
LEAVE;
}
+
+
+char* Perl_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* Perl_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));
+}
+
+
#include "XSUB.h"
/* Efficient sub that returns a constant scalar value. */
static void
-const_sv_xsub(pTHXo_ CV* cv)
+const_sv_xsub(pTHX_ CV* cv)
{
dXSARGS;
if (items != 0) {
https://perl5.git.perl.org / perl5.git / blobdiff