}
break;
case OP_METHOD_NAMED:
+ case OP_METHOD_SUPER:
SvREFCNT_dec(cMETHOPx(o)->op_u.op_meth_sv);
cMETHOPx(o)->op_u.op_meth_sv = NULL;
#ifdef USE_ITHREADS
if (type == OP_LINESEQ || type == OP_SCOPE ||
type == OP_LEAVE || type == OP_LEAVETRY)
{
- OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = OP_SIBLING(kid)) {
- if (OP_HAS_SIBLING(kid)) {
+ OP *kid, *sib;
+ for (kid = cLISTOPo->op_first; kid; kid = sib) {
+ if ((sib = OP_SIBLING(kid))
+ && ( OP_HAS_SIBLING(sib) || sib->op_type != OP_NULL
+ || ( sib->op_targ != OP_NEXTSTATE
+ && sib->op_targ != OP_DBSTATE )))
+ {
scalarvoid(kid);
}
}
#ifdef USE_ITHREADS
/* Relocate all the METHOP's SVs to the pad for thread safety. */
case OP_METHOD_NAMED:
+ case OP_METHOD_SUPER:
op_relocate_sv(&cMETHOPx(o)->op_u.op_meth_sv, &o->op_targ);
break;
#endif
break;
}
goto nomod;
+
+ case OP_SCALAR:
+ op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
+ goto nomod;
}
/* [20011101.069] File test operators interpret OPf_REF to mean that
*/
SvREFCNT_inc_simple_void(PL_compcv);
+ CvLVALUE_on(PL_compcv);
/* these lines are just an unrolled newANONATTRSUB */
expr = newSVOP(OP_ANONCODE, 0,
MUTABLE_SV(newATTRSUB(floor, 0, NULL, NULL, expr)));
else
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
if (padoff) {
- SV *const namesv = PAD_COMPNAME_SV(padoff);
- STRLEN len;
- const char *const name = SvPV_const(namesv, len);
+ PADNAME * const pn = PAD_COMPNAME(padoff);
+ const char * const name = PadnamePV(pn);
- if (len == 2 && name[0] == '$' && name[1] == '_')
+ if (PadnameLEN(pn) == 2 && name[0] == '$' && name[1] == '_')
iterpflags |= OPpITER_DEF;
}
}
loop = tmp;
}
else if (!loop->op_slabbed)
+ {
loop = (LOOP*)PerlMemShared_realloc(loop, sizeof(LOOP));
+#ifdef PERL_OP_PARENT
+ loop->op_last->op_sibling = (OP *)loop;
+#endif
+ }
loop->op_targ = padoff;
wop = newWHILEOP(flags, 1, loop, newOP(OP_ITER, 0), block, cont, 0);
return wop;
cv = *spot;
else {
MAGIC *mg;
- SvUPGRADE(name, SVt_PVMG);
- mg = mg_find(name, PERL_MAGIC_proto);
+ SvUPGRADE((SV *)name, SVt_PVMG);
+ mg = mg_find((SV *)name, PERL_MAGIC_proto);
assert (SvTYPE(*spot) == SVt_PVCV);
if (CvNAMED(*spot))
hek = CvNAME_HEK(*spot);
CvNAME_HEK_set(*spot, hek =
share_hek(
PadnamePV(name)+1,
- PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1), hash
+ (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
+ hash
)
);
CvLEXICAL_on(*spot);
cv = (CV *)mg->mg_obj;
}
else {
- sv_magic(name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
- mg = mg_find(name, PERL_MAGIC_proto);
+ sv_magic((SV *)name, &PL_sv_undef, PERL_MAGIC_proto, NULL, 0);
+ mg = mg_find((SV *)name, PERL_MAGIC_proto);
}
spot = (CV **)(svspot = &mg->mg_obj);
}
U32 hash;
PERL_HASH(hash, PadnamePV(name)+1, PadnameLEN(name)-1);
hek = share_hek(PadnamePV(name)+1,
- PadnameLEN(name)-1 * (PadnameUTF8(name) ? -1 : 1),
+ (PadnameLEN(name)-1) * (PadnameUTF8(name) ? -1 : 1),
hash);
}
CvNAME_HEK_set(cv, hek);
const OPCODE type = newop->op_type;
if (OP_HAS_SIBLING(newop))
return o;
- if (o->op_type == OP_REFGEN && !(newop->op_flags & OPf_PARENS)
- && (type == OP_RV2AV || type == OP_PADAV
- || type == OP_RV2HV || type == OP_PADHV
- || type == OP_RV2CV))
+ if (o->op_type == OP_REFGEN
+ && ( type == OP_RV2CV
+ || ( !(newop->op_flags & OPf_PARENS)
+ && ( type == OP_RV2AV || type == OP_PADAV
+ || type == OP_RV2HV || type == OP_PADHV))))
NOOP; /* OK (allow srefgen for \@a and \%h) */
else if (!(PL_opargs[type] & OA_RETSCALAR))
return o;
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
- assert (sizeof(PADOP) <= sizeof(SVOP));
+ STATIC_ASSERT_STMT(sizeof(PADOP) <= sizeof(SVOP));
kPADOP->op_padix = pad_alloc(OP_GV, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
PAD_SETSV(kPADOP->op_padix, MUTABLE_SV(SvREFCNT_inc_simple_NN(gv)));
*/
priv = OPpDEREF;
if (kid->op_type == OP_PADSV) {
- SV *const namesv
+ PADNAME * const pn
= PAD_COMPNAME_SV(kid->op_targ);
- name = SvPV_const(namesv, len);
- name_utf8 = SvUTF8(namesv);
+ name = PadnamePV (pn);
+ len = PadnameLEN(pn);
+ name_utf8 = PadnameUTF8(pn);
}
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
OP *
Perl_ck_method(pTHX_ OP *o)
{
- SV* sv;
+ SV *sv, *methsv;
const char* method;
+ char* compatptr;
+ int utf8;
+ STRLEN len, nsplit = 0, i;
OP * const kid = cUNOPo->op_first;
PERL_ARGS_ASSERT_CK_METHOD;
if (kid->op_type != OP_CONST) return o;
sv = kSVOP->op_sv;
+
+ /* replace ' with :: */
+ while ((compatptr = strchr(SvPVX(sv), '\''))) {
+ *compatptr = ':';
+ sv_insert(sv, compatptr - SvPVX_const(sv), 0, ":", 1);
+ }
+
method = SvPVX_const(sv);
- if (!(strchr(method, ':') || strchr(method, '\''))) {
- OP *cmop;
- if (!SvIsCOW_shared_hash(sv)) {
- sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
- }
- else {
- kSVOP->op_sv = NULL;
- }
- cmop = newMETHOP_named(OP_METHOD_NAMED, 0, sv);
+ len = SvCUR(sv);
+ utf8 = SvUTF8(sv) ? -1 : 1;
+
+ for (i = len - 1; i > 0; --i) if (method[i] == ':') {
+ nsplit = i+1;
+ break;
+ }
+
+ methsv = newSVpvn_share(method+nsplit, utf8*(len - nsplit), 0);
+
+ if (!nsplit) { /* $proto->method() */
+ op_free(o);
+ return newMETHOP_named(OP_METHOD_NAMED, 0, methsv);
+ }
+
+ if (nsplit == 7 && memEQ(method, "SUPER::", nsplit)) { /* $proto->SUPER::method() */
op_free(o);
- return cmop;
+ return newMETHOP_named(OP_METHOD_SUPER, 0, methsv);
}
+
return o;
}
kid = kBINOP->op_first;
do {
if (kid->op_type == OP_PADSV) {
- SV * const name = PAD_COMPNAME_SV(kid->op_targ);
- if (SvCUR(name) == 2 && *SvPVX(name) == '$'
- && (SvPVX(name)[1] == 'a' || SvPVX(name)[1] == 'b'))
+ PADNAME * const name = PAD_COMPNAME(kid->op_targ);
+ if (PadnameLEN(name) == 2 && *PadnamePV(name) == '$'
+ && ( PadnamePV(name)[1] == 'a'
+ || PadnamePV(name)[1] == 'b' ))
/* diag_listed_as: "my %s" used in sort comparison */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"\"%s %s\" used in sort comparison",
- SvPAD_STATE(name) ? "state" : "my",
- SvPVX(name));
+ PadnameIsSTATE(name)
+ ? "state"
+ : "my",
+ PadnamePV(name));
}
} while ((kid = OP_SIBLING(kid)));
return;
}
assert(!PadnameIsOUR(name));
if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
- MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
+ MAGIC * mg = mg_find((SV *)name, PERL_MAGIC_proto);
assert(mg);
assert(mg->mg_obj);
return (CV *)mg->mg_obj;
bad_type_gv(arg, "symbol", namegv, 0, o3);
break;
case '&':
- if (o3->op_type == OP_ENTERSUB)
+ if (o3->op_type == OP_ENTERSUB
+ && !(o3->op_flags & OPf_STACKED))
goto wrapref;
if (!contextclass)
- bad_type_gv(arg, "subroutine entry", namegv, 0,
+ bad_type_gv(arg, "subroutine", namegv, 0,
o3);
break;
case '$':
case '@':
if (o3->op_type == OP_RV2AV ||
o3->op_type == OP_PADAV)
+ {
+ o3->op_flags &=~ OPf_PARENS;
goto wrapref;
+ }
if (!contextclass)
bad_type_gv(arg, "array", namegv, 0, o3);
break;
case '%':
if (o3->op_type == OP_RV2HV ||
o3->op_type == OP_PADHV)
+ {
+ o3->op_flags &=~ OPf_PARENS;
goto wrapref;
+ }
if (!contextclass)
bad_type_gv(arg, "hash", namegv, 0, o3);
break;
return op_convert_list(opnum,0,aop);
}
}
- assert(0);
+ NOT_REACHED;
return entersubop;
}
OP *aop, *cvop;
CV *cv;
GV *namegv;
+ SV **const_class = NULL;
PERL_ARGS_ASSERT_CK_SUBR;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
o->op_private |= OPpENTERSUB_DB;
- if (cvop->op_type == OP_RV2CV) {
- o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
- op_null(cvop);
- } else if (cvop->op_type == OP_METHOD || cvop->op_type == OP_METHOD_NAMED) {
- if (aop->op_type == OP_CONST)
- aop->op_private &= ~OPpCONST_STRICT;
- else if (aop->op_type == OP_LIST) {
- OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
- if (sib && sib->op_type == OP_CONST)
- sib->op_private &= ~OPpCONST_STRICT;
- }
+ switch (cvop->op_type) {
+ case OP_RV2CV:
+ o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
+ op_null(cvop);
+ break;
+ case OP_METHOD:
+ case OP_METHOD_NAMED:
+ case OP_METHOD_SUPER:
+ if (aop->op_type == OP_CONST) {
+ aop->op_private &= ~OPpCONST_STRICT;
+ const_class = &cSVOPx(aop)->op_sv;
+ }
+ else if (aop->op_type == OP_LIST) {
+ OP * const sib = OP_SIBLING(((UNOP*)aop)->op_first);
+ if (sib && sib->op_type == OP_CONST) {
+ sib->op_private &= ~OPpCONST_STRICT;
+ const_class = &cSVOPx(sib)->op_sv;
+ }
+ }
+ /* make class name a shared cow string to speedup method calls */
+ /* constant string might be replaced with object, f.e. bigint */
+ if (const_class && !SvROK(*const_class)) {
+ STRLEN len;
+ const char* str = SvPV(*const_class, len);
+ if (len) {
+ SV* const shared = newSVpvn_share(
+ str, SvUTF8(*const_class) ? -len : len, 0
+ );
+ SvREFCNT_dec(*const_class);
+ *const_class = shared;
+ }
+ }
+ break;
}
if (!cv) {
https://perl5.git.perl.org / perl5.git / blobdiff