fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
"in variable %"SVf" of type %"HEKf,
SVfARG(*svp), SVfARG(lexname),
SV *lexname;
GV **fields;
SV **svp;
- const char *key;
- STRLEN keylen;
SVOP *first_key_op, *key_op;
S_scalar_slice_warning(aTHX_ o);
if (key_op->op_type != OP_CONST)
continue;
svp = cSVOPx_svp(key_op);
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
"in variable %"SVf" of type %"HEKf,
SVfARG(*svp), SVfARG(lexname),
attrs)));
}
+STATIC void
+S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
+{
+ OP *new_proto = NULL;
+ STRLEN pvlen;
+ char *pv;
+ OP *o;
+
+ PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
+
+ if (!*attrs)
+ return;
+
+ o = *attrs;
+ if (o->op_type == OP_CONST) {
+ pv = SvPV(cSVOPo_sv, pvlen);
+ if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
+ SV ** const tmpo = cSVOPx_svp(o);
+ SvREFCNT_dec(cSVOPo_sv);
+ *tmpo = tmpsv;
+ new_proto = o;
+ *attrs = NULL;
+ }
+ } else if (o->op_type == OP_LIST) {
+ OP * lasto = NULL;
+ assert(o->op_flags & OPf_KIDS);
+ assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
+ /* Counting on the first op to hit the lasto = o line */
+ for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
+ if (o->op_type == OP_CONST) {
+ pv = SvPV(cSVOPo_sv, pvlen);
+ if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
+ SV ** const tmpo = cSVOPx_svp(o);
+ SvREFCNT_dec(cSVOPo_sv);
+ *tmpo = tmpsv;
+ if (new_proto && ckWARN(WARN_MISC)) {
+ STRLEN new_len;
+ const char * newp = SvPV(cSVOPo_sv, new_len);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
+ UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
+ op_free(new_proto);
+ }
+ else if (new_proto)
+ op_free(new_proto);
+ new_proto = o;
+ lasto->op_sibling = o->op_sibling;
+ continue;
+ }
+ }
+ lasto = o;
+ }
+ /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
+ would get pulled in with no real need */
+ if (!cLISTOPx(*attrs)->op_first->op_sibling) {
+ op_free(*attrs);
+ *attrs = NULL;
+ }
+ }
+
+ if (new_proto) {
+ SV *svname;
+ if (isGV(name)) {
+ svname = sv_newmortal();
+ gv_efullname3(svname, name, NULL);
+ }
+ else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
+ svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
+ else
+ svname = (SV *)name;
+ if (ckWARN(WARN_ILLEGALPROTO))
+ (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
+ if (*proto && ckWARN(WARN_PROTOTYPE)) {
+ STRLEN old_len, new_len;
+ const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
+ const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
+
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+ "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
+ " in %"SVf,
+ UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
+ UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
+ SVfARG(svname));
+ }
+ if (*proto)
+ op_free(*proto);
+ *proto = new_proto;
+ }
+}
+
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
break;
case OP_REPEAT:
if (o->op_private & OPpREPEAT_DOLIST) goto nope;
+ break;
+ case OP_SREFGEN:
+ if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
+ || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
+ goto nope;
}
if (PL_parser && PL_parser->error_count)
else
{
newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
- newop->op_folded = 1;
+ if (type != OP_STRINGIFY) newop->op_folded = 1;
}
op_getmad(o,newop,'f');
return newop;
[CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
spot = (CV **)svspot;
+ if (!(PL_parser && PL_parser->error_count))
+ move_proto_attr(&proto, &attrs, (GV *)name);
+
if (proto) {
assert(proto->op_type == OP_CONST);
ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
OPSLAB *slab = NULL;
#endif
- if (proto) {
- assert(proto->op_type == OP_CONST);
- ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
- ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
- }
- else
- ps = NULL;
-
if (o_is_gv) {
gv = (GV*)o;
o = NULL;
has_name = FALSE;
}
+ if (!ec)
+ move_proto_attr(&proto, &attrs, gv);
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
+ }
+ else
+ ps = NULL;
+
if (!PL_madskills) {
if (o)
SAVEFREEOP(o);
old_count
= (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
- assert(oldoldop->op_targ + old_count == base);
- if (old_count < OPpPADRANGE_COUNTMASK - count) {
+ /* Do not assume pad offsets for $c and $d are con-
+ tiguous in
+ my ($a,$b,$c);
+ my ($d,$e,$f);
+ */
+ if ( oldoldop->op_targ + old_count == base
+ && old_count < OPpPADRANGE_COUNTMASK - count) {
base = oldoldop->op_targ;
count += old_count;
reuse = 1;
https://perl5.git.perl.org / perl5.git / blobdiff