/* 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)
+
+#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
-#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
-#define SLAB_SIZE 8192
-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 \
- var = (type *) Slab_Alloc(m,c*sizeof(type)); \
- } while (0)
+#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) {
+ 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
cop_free((COP*)o);
op_clear(o);
-
-#ifdef PL_OP_SLAB_ALLOC
- if ((char *) o == PL_OpPtr)
- {
- }
-#else
- Safefree(o);
-#endif
+ FreeOp(o);
}
void
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
+ STRLEN len;
+ char *s = SvPV(cop->cop_io,len);
+ Perl_warn(aTHX_ "io='%.*s'",(int) len,s);
+#else
SvREFCNT_dec(cop->cop_io);
+#endif
+ }
}
void
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:
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;
}
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;
{
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 "
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:%"UVuf,
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;
}
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 *
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);
}
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;
op_free(o);
}
else {
- deprecate("\"package\" with no arguments");
+ deprecate_old("\"package\" with no arguments");
sv_setpv(PL_curstname,"<none>");
PL_curstash = Nullhv;
}
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)
if (gv == PL_defgv || SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
- }
+ }
}
else
break;
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef ) {
+ if (svp && *svp != &PL_sv_undef ) {
(void)SvIOK_on(*svp);
SvIVX(*svp) = PTR2IV(cop);
- }
+ }
}
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
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
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);
else
stash = PL_curstash;
}
- apply_attrs(stash, rcv, attrs);
+ apply_attrs(stash, rcv, attrs, FALSE);
}
if (cv) { /* must reuse cv if autoloaded */
if (!block) {
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))) {
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];
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
- && ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Using an array as a reference is deprecated");
}
return newUNOP(OP_RV2AV, 0, scalar(o));
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
- && ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"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);
Perl_warner(aTHX_ 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 (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)) {
goto again;
break;
case ']':
- if (contextclass)
- contextclass = 0;
- else
+ 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 '*':
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 &
}
}
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;
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
-
https://perl5.git.perl.org / perl5.git / blobdiff