/* op.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, 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.
* either way, as the saying is, if you follow me." --the Gaffer
*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
-/* #define PL_OP_SLAB_ALLOC */
+#if defined(PL_OP_SLAB_ALLOC)
-#ifdef PL_OP_SLAB_ALLOC
-#define SLAB_SIZE 8192
-static char *PL_OpPtr = NULL;
-static int PL_OpSpace = 0;
-#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
- var = (type *)(PL_OpPtr -= c*sizeof(type)); \
- else \
- var = (type *) Slab_Alloc(m,c*sizeof(type)); \
- } while (0)
+#ifndef PERL_SLAB_SIZE
+#define PERL_SLAB_SIZE 2048
+#endif
+
+#define NewOp(m,var,c,type) \
+ STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
+
+#define FreeOp(p) Slab_Free(p)
STATIC void *
S_Slab_Alloc(pTHX_ int m, size_t sz)
{
- Newz(m,PL_OpPtr,SLAB_SIZE,char);
- PL_OpSpace = SLAB_SIZE - sz;
- return PL_OpPtr += PL_OpSpace;
+ /*
+ * To make incrementing use count easy PL_OpSlab is an I32 *
+ * To make inserting the link to slab PL_OpPtr is I32 **
+ * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
+ * Add an overhead for pointer to slab and round up as a number of pointers
+ */
+ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
+ if ((PL_OpSpace -= sz) < 0) {
+ PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
+ if (!PL_OpPtr) {
+ return NULL;
+ }
+ Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
+ /* We reserve the 0'th I32 sized chunk as a use count */
+ PL_OpSlab = (I32 *) PL_OpPtr;
+ /* Reduce size by the use count word, and by the size we need.
+ * Latter is to mimic the '-=' in the if() above
+ */
+ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
+ /* Allocation pointer starts at the top.
+ Theory: because we build leaves before trunk allocating at end
+ means that at run time access is cache friendly upward
+ */
+ PL_OpPtr += PERL_SLAB_SIZE;
+ }
+ assert( PL_OpSpace >= 0 );
+ /* Move the allocation pointer down */
+ PL_OpPtr -= sz;
+ assert( PL_OpPtr > (I32 **) PL_OpSlab );
+ *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
+ (*PL_OpSlab)++; /* Increment use count of slab */
+ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
+ assert( *PL_OpSlab > 0 );
+ return (void *)(PL_OpPtr + 1);
+}
+
+STATIC void
+S_Slab_Free(pTHX_ void *op)
+{
+ I32 **ptr = (I32 **) op;
+ I32 *slab = ptr[-1];
+ assert( ptr-1 > (I32 **) slab );
+ assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
+ assert( *slab > 0 );
+ if (--(*slab) == 0) {
+ #ifdef NETWARE
+ #define PerlMemShared PerlMem
+ #endif
+
+ PerlMemShared_free(slab);
+ if (slab == PL_OpSlab) {
+ PL_OpSpace = 0;
+ }
+ }
}
#else
#define NewOp(m, var, c, type) Newz(m, var, c, type)
+#define FreeOp(p) Safefree(p)
#endif
/*
* In the following definition, the ", Nullop" is just to make the compiler
|| ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
&& strEQ(name, SvPVX(sv)))
{
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"%s\" variable %s masks earlier declaration in same %s",
(PL_in_my == KEY_our ? "our" : "my"),
name,
&& ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
&& strEQ(name, SvPVX(sv)))
{
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"our\" variable %s redeclared", name);
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"\t(Did you mean \"local\" instead of \"our\"?)\n");
break;
}
if (ckWARN(WARN_CLOSURE)
&& !CvUNIQUE(bcv) && !CvUNIQUE(cv))
{
- Perl_warner(aTHX_ WARN_CLOSURE,
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" may be unavailable",
name);
}
if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
&& !(SvFLAGS(sv) & SVpad_OUR))
{
- Perl_warner(aTHX_ WARN_CLOSURE,
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" will not stay shared", name);
}
}
if (PL_min_intro_pending && fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv));
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
cop_free((COP*)o);
op_clear(o);
-
-#ifdef PL_OP_SLAB_ALLOC
- if ((char *) o == PL_OpPtr)
- {
- }
-#else
- Safefree(o);
-#endif
+ FreeOp(o);
}
void
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);
pmop = pmop->op_pmnext;
}
}
-#ifdef USE_ITHREADS
- Safefree(PmopSTASHPV(cPMOPo));
-#else
- /* NOTE: PMOP.op_pmstash is not refcounted */
-#endif
+ PmopSTASH_free(cPMOPo);
}
cPMOPo->op_pmreplroot = Nullop;
/* we use the "SAFE" version of the PM_ macros here
SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
}
-#endif
+#endif
break;
}
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label);
-#ifdef USE_ITHREADS
- Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
- Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
-#else
- /* NOTE: COP.cop_stash is not refcounted */
- SvREFCNT_dec(CopFILEGV(cop));
-#endif
+ Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ CopFILE_free(cop);
+ CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
SvREFCNT_dec(cop->cop_warnings);
- if (! specialCopIO(cop->cop_io))
+ if (! specialCopIO(cop->cop_io)) {
+#ifdef USE_ITHREADS
+#if 0
+ STRLEN len;
+ char *s = SvPV(cop->cop_io,len);
+ Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
+#endif
+#else
SvREFCNT_dec(cop->cop_io);
+#endif
+ }
}
void
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
CopLINE_set(PL_curcop, oldline);
}
}
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplroot)
- deprecate("implicit split to @_");
+ deprecate_old("implicit split to @_");
}
/* FALL THROUGH */
case OP_MATCH:
}
WITH_THR(PL_curcop = &PL_compiling);
break;
+ case OP_SORT:
+ if (ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
}
return o;
}
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplroot)
- deprecate("implicit split to @_");
+ deprecate_old("implicit split to @_");
}
break;
}
if (useless && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
return o;
}
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)
{
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;
newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
newop->op_private |= OPpLVAL_INTRO;
break;
}
-
+
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 */
}
-
- okid = kid;
+
+ okid = kid;
kid = kUNOP->op_first;
if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
kid = kUNOP->op_first;
- if (kid->op_type == OP_NULL)
+ 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:
okid->op_private |= OPpLVAL_INTRO;
break;
}
-
+
cv = GvCV(kGVOP_gv);
if (!cv)
goto restore_2cv;
goto nomod;
PL_modcount++;
break;
-
+
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
mod(kid, type);
case OP_PUSHMARK:
break;
-
+
case OP_KEYS:
if (type != OP_SASSIGN)
goto nomod;
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;
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_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
+ yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
+ }
if (attrs) {
GV *gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
(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)
}
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
- SV *padsv;
SV **namesvp;
PL_in_my = FALSE;
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 *
const char *sample = ((left->op_type == OP_RV2AV ||
left->op_type == OP_PADAV)
? "@array" : "%hash");
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
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 ||
right->op_type == OP_TRANS)) {
right->op_flags |= OPf_STACKED;
- if ((right->op_type != OP_MATCH &&
- ! (right->op_type == OP_TRANS &&
- right->op_private & OPpTRANS_IDENTICAL)) ||
- /* if SV has magic, then match on original SV, not on its copy.
- see note in pp_helem() */
- (right->op_type == OP_MATCH &&
- (left->op_type == OP_AELEM ||
- left->op_type == OP_HELEM ||
- left->op_type == OP_AELEMFAST)))
+ if (right->op_type != OP_MATCH &&
+ ! (right->op_type == OP_TRANS &&
+ right->op_private & OPpTRANS_IDENTICAL))
left = mod(left, right->op_type);
if (right->op_type == OP_TRANS)
o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
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;
s++;
if (*s == ';' || *s == '=')
- Perl_warner(aTHX_ WARN_PARENTHESIS,
+ Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
}
}
nope:
- if (!(PL_opargs[type] & OA_OTHERINT))
- return o;
-
- if (!(PL_hints & HINT_INTEGER)) {
- if (type == OP_MODULO
- || type == OP_DIVIDE
- || !(o->op_flags & OPf_KIDS))
- {
- return o;
- }
-
- for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
- if (curop->op_type == OP_CONST) {
- if (SvIOK(((SVOP*)curop)->op_sv))
- continue;
- return o;
- }
- if (PL_opargs[curop->op_type] & OA_RETINTEGER)
- continue;
- return o;
- }
- o->op_ppaddr = PL_ppaddr[++(o->op_type)];
- }
-
return o;
}
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ o->op_seq = 0; /* needs to be revisited in peep() */
curop = ((UNOP*)o)->op_first;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
op_free(curop);
first->op_last = last->op_last;
first->op_flags |= (last->op_flags & OPf_KIDS);
-#ifdef PL_OP_SLAB_ALLOC
-#else
- Safefree(last);
-#endif
+ FreeOp(last);
+
return (OP*)first;
}
U8 range_mark = UTF_TO_NATIVE(0xff);
sv_catpvn(transv, (char *)&range_mark, 1);
}
- t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
+ t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
+ UNICODE_ALLOW_SUPER);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
t = (U8*)SvPVX(transv);
tlen = SvCUR(transv);
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_pmoffset = SvIV(repointer);
SvREPADTMP_off(repointer);
sv_setiv(repointer,0);
- } else {
+ } else {
repointer = newSViv(0);
av_push(PL_regex_padav,SvREFCNT_inc(repointer));
pmop->op_pmoffset = av_len(PL_regex_padav);
}
}
#endif
-
+
/* link into pm list */
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
+ if (DO_UTF8(pat))
+ pm->op_pmdynflags |= PMdf_UTF8;
PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
/* 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,
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);
- }
+ /* The "did you use incorrect case?" warning used to be here.
+ * The problem is that on case-insensitive filesystems one
+ * might get false positives for "use" (and "require"):
+ * "use Strict" or "require CARP" will work. This causes
+ * portability problems for the script: in case-strict
+ * filesystems the script will stop working.
+ *
+ * The "incorrect case" warning checked whether "use Foo"
+ * imported "Foo" to your namespace, but that is wrong, too:
+ * there is no requirement nor promise in the language that
+ * a Foo.pm should or would contain anything in package "Foo".
+ *
+ * There is very little Configure-wise that can be done, either:
+ * the case-sensitivity of the build filesystem of Perl does not
+ * help in guessing the case-sensitivity of the runtime environment.
+ */
safefree(packname);
}
}
/*
+=head1 Embedding Functions
+
=for apidoc load_module
Loads the module whose name is pointed to by the string part of name.
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
if (gv == PL_defgv || SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
- }
+ }
}
else
break;
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);
}
}
}
if (first->op_type == OP_CONST) {
if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
- Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
+ Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
if (warnop) {
line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Value of %s%s can be \"0\"; test with defined()",
PL_op_desc[warnop],
((warnop == OP_READLINE || warnop == OP_GLOB)
case OP_SASSIGN:
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
- || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
+ || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
|| k1->op_type == OP_EACH)
expr = newUNOP(OP_DEFINED, 0, expr);
break;
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LOOP);
+ FreeOp(loop);
loop = tmp;
}
#else
* 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) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
- && 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);
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
else
sv_catpv(msg, "none");
- Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
}
}
-static void const_sv_xsub(pTHXo_ CV* cv);
+static void const_sv_xsub(pTHX_ CV* cv);
/*
+
+=head1 Optree Manipulation Functions
+
=for apidoc cv_const_sv
If C<cv> is a constant sub eligible for inlining. returns the constant
name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV *sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
+ Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
+ PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
aname = SvPVX(sv);
}
else
aname = Nullch;
- gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
+ gv = gv_fetchpv(name ? name : (aname ? aname :
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
SVt_PVCV);
if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
&& ckWARN_d(WARN_PROTOTYPE))
{
- Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
cv_ckproto((CV*)gv, NULL, ps);
}
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if (!block && !attrs) {
+ if (CvFLAGS(PL_compcv)) {
+ /* might have had built-in attrs applied */
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+ }
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
&& (!const_sv || sv_cmp(cv_const_sv(cv), const_sv))))
{
line_t oldline = CopLINE(PL_curcop);
- CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE,
+ if (PL_copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_copline);
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined", name);
CopLINE_set(PL_curcop, oldline);
else
stash = PL_curstash;
}
- apply_attrs(stash, rcv, attrs);
+ apply_attrs(stash, rcv, attrs, FALSE);
}
if (cv) { /* must reuse cv if autoloaded */
if (!block) {
}
}
- /* 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)
- && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
- && 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();
PL_checkav = newAV();
DEBUG_x( dump_sub(gv) );
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
av_unshift(PL_checkav, 1);
av_store(PL_checkav, 0, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
PL_initav = newAV();
DEBUG_x( dump_sub(gv) );
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
av_push(PL_initav, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
}
SAVESPTR(PL_curstash);
SAVECOPSTASH(PL_curcop);
PL_curstash = stash;
-#ifdef USE_ITHREADS
- CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
-#else
- CopSTASH(PL_curcop) = stash;
-#endif
+ CopSTASH_set(PL_curcop,stash);
}
cv = newXS(name, const_sv_xsub, __FILE__);
CV *
Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
{
- GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
+ GV *gv = gv_fetchpv(name ? name :
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+ GV_ADDMULTI, SVt_PVCV);
register CV *cv;
if ((cv = (name ? GvCV(gv) : Nullcv))) {
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE,
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined"
,name);
if (!PL_checkav)
PL_checkav = newAV();
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
av_unshift(PL_checkav, 1);
av_store(PL_checkav, 0, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
if (!PL_initav)
PL_initav = newAV();
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
av_push(PL_initav, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
}
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
line_t oldline = CopLINE(PL_curcop);
-
- CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
+ if (PL_copline != NOLINE)
+ CopLINE_set(PL_curcop, PL_copline);
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return ref(o, OP_RV2AV);
-
+
case OP_RV2SV:
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
default:
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
break;
}
return o;
default:
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
break;
}
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
&& ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
"Using an array as a reference is deprecated");
}
return newUNOP(OP_RV2AV, 0, scalar(o));
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
&& ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
"Using a hash as a reference is deprecated");
}
return newUNOP(OP_RV2HV, 0, scalar(o));
!(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
-
+
return o;
}
op_free(kUNOP->op_first);
}
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);
}
case OA_AVREF:
if ((type == OP_PUSH || type == OP_UNSHIFT)
&& !kid->op_sibling && ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Useless use of %s with no values",
PL_op_desc[type]);
-
+
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
- if (ckWARN(WARN_DEPRECATED))
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%s missing the @ in argument %"IVdf" of %s()",
name, (IV)numargs, PL_op_desc[type]);
op_free(kid);
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
- if (ckWARN(WARN_DEPRECATED))
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%s missing the %% in argument %"IVdf" of %s()",
name, (IV)numargs, PL_op_desc[type]);
op_free(kid);
OP *newop = newGVOP(OP_GV, 0,
gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
SVt_PVIO) );
+ if (!(o->op_private & 1) && /* if not unop */
+ kid == cLISTOPo->op_last)
+ cLISTOPo->op_last = newop;
op_free(kid);
kid = newop;
}
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. */
if (!gv) {
GV *glob_gv;
ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
- Nullsv, Nullsv);
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
}
#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;
OP *
Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
{
- if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
+ if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
/* This is needed for
break; /* Globals via GV can be undef */
case OP_PADAV:
case OP_AASSIGN: /* Is this a good idea? */
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"defined(@array) is deprecated");
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"\t(Maybe you should just omit the defined()?)\n");
break;
case OP_RV2HV:
*/
break; /* Globals via GV can be undef */
case OP_PADHV:
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"defined(%%hash) is deprecated");
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"\t(Maybe you should just omit the defined()?)\n");
break;
default:
kid = kid->op_sibling;
}
}
-
+
if (!kid)
append_elem(o->op_type, o, newDEFSVOP());
/* 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);
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
-
+
op_free(o);
#ifdef USE_5005THREADS
if (!CvUNIQUE(PL_compcv)) {
char *pmstr = "STRING";
if (PM_GETRE(kPMOP))
pmstr = PM_GETRE(kPMOP)->precomp;
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(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) {
+ char *p = proto;
+ char s = *p;
+ contextclass = 0;
+ *p = '\0';
+ while (*--p != '[');
+ bad_type(arg, Perl_form(aTHX_ "one of %s", p),
+ gv_ename(namegv), o2);
+ *proto = s;
+ } 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
else if (o->op_next->op_type == OP_RV2AV) {
OP* pop = o->op_next->op_next;
IV i;
- if (pop->op_type == OP_CONST &&
+ if (pop && pop->op_type == OP_CONST &&
(PL_op = pop->op_next) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
/* XXX could check prototype here instead of just carping */
SV *sv = sv_newmortal();
gv_efullname3(sv, gv, Nullch);
- Perl_warner(aTHX_ WARN_PROTOTYPE,
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%s() called too early to check prototype",
SvPV_nolen(sv));
}
&& 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 20010811 */
- o->op_next->op_type = OP_RCATLINE;
- o->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++;
line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
- Perl_warner(aTHX_ WARN_EXEC,
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
"Statement unlikely to be reached");
- Perl_warner(aTHX_ WARN_EXEC,
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
"\t(Maybe you meant system() when you said exec()?)\n");
CopLINE_set(PL_curcop, oldline);
}
}
break;
-
+
case OP_HELEM: {
UNOP *rop;
SV *lexname;
I32 ind;
char *key = NULL;
STRLEN keylen;
-
+
o->op_seq = PL_op_seqmax++;
if (((BINOP*)o)->op_last->op_type != OP_CONST)
*svp = sv;
break;
}
-
+
case OP_HSLICE: {
UNOP *rop;
SV *lexname;
LEAVE;
}
-#ifdef PERL_CUSTOM_OPS
-char* custom_op_name(pTHX_ OP* o)
+
+
+char* Perl_custom_op_name(pTHX_ OP* o)
{
IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
return SvPV_nolen(HeVAL(he));
}
-char* custom_op_desc(pTHX_ OP* o)
+char* Perl_custom_op_desc(pTHX_ OP* o)
{
IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
return SvPV_nolen(HeVAL(he));
}
-#endif
+
#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) {
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
-
https://perl5.git.perl.org / perl5.git / blobdiff