/* op.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, 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.
: CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
#define PAD_MAX 999999999
+#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
STATIC char*
S_gv_ename(pTHX_ GV *gv)
if (!(PL_in_my == KEY_our ||
isALPHA(name[1]) ||
- (PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
+ (PL_hints & HINT_UTF8 && UTF8_IS_START(name[1])) ||
(name[1] == '_' && (int)strlen(name) > 2)))
{
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
if (*name != '$')
yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"%s\"",
name, PL_in_my == KEY_our ? "our" : "my"));
- SvOBJECT_on(sv);
+ SvFLAGS(sv) |= SVpad_TYPED;
(void)SvUPGRADE(sv, SVt_PVMG);
SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
- PL_sv_objcount++;
}
if (PL_in_my == KEY_our) {
(void)SvUPGRADE(sv, SVt_PVGV);
(void)SvUPGRADE(namesv, SVt_PVGV);
GvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)GvSTASH(proto_namesv));
}
- if (SvOBJECT(proto_namesv)) { /* A typed var */
- SvOBJECT_on(namesv);
+ if (SvFLAGS(proto_namesv) & SVpad_TYPED) { /* A typed lexical */
+ SvFLAGS(namesv) |= SVpad_TYPED;
(void)SvUPGRADE(namesv, SVt_PVMG);
SvSTASH(namesv) = (HV*)SvREFCNT_inc((SV*)SvSTASH(proto_namesv));
- PL_sv_objcount++;
}
return newoff;
}
switch (CxTYPE(cx)) {
default:
if (i == 0 && saweval) {
- seq = cxstack[saweval].blk_oldcop->cop_seq;
return pad_findlex(name, newoff, seq, PL_main_cv, -1, saweval, 0);
}
break;
case CXt_EVAL:
switch (cx->blk_eval.old_op_type) {
case OP_ENTEREVAL:
- if (CxREALEVAL(cx))
+ if (CxREALEVAL(cx)) {
+ PADOFFSET off;
saweval = i;
+ seq = cxstack[i].blk_oldcop->cop_seq;
+ startcv = cxstack[i].blk_eval.cv;
+ if (startcv && CvOUTSIDE(startcv)) {
+ off = pad_findlex(name, newoff, seq, CvOUTSIDE(startcv),
+ i-1, saweval, 0);
+ if (off) /* continue looking if not found here */
+ return off;
+ }
+ }
break;
case OP_DOFILE:
case OP_REQUIRE:
saweval = i; /* so we know where we were called from */
continue;
}
- seq = cxstack[saweval].blk_oldcop->cop_seq;
return pad_findlex(name, newoff, seq, cv, i-1, saweval,FINDLEX_NOSEARCH);
}
}
break;
case ';':
sv_setpv(sv, "\034");
- sv_magic(sv, 0, 0, name, 1);
+ sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
break;
case '&':
case '`':
/* case '!': */
default:
- sv_magic(sv, 0, 0, name, 1);
+ sv_magic(sv, 0, PERL_MAGIC_sv, name, 1);
}
DEBUG_S(PerlIO_printf(Perl_error_log,
"find_threadsv: new SV %p for $%s%c\n",
#endif
}
-STATIC void
-S_op_clear(pTHX_ OP *o)
+void
+Perl_op_clear(pTHX_ OP *o)
{
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
case OP_MATCH:
case OP_QR:
clear_pmop:
+ {
+ HV *pmstash = PmopSTASH(cPMOPo);
+ if (pmstash && SvREFCNT(pmstash)) {
+ PMOP *pmop = HvPMROOT(pmstash);
+ PMOP *lastpmop = NULL;
+ while (pmop) {
+ if (cPMOPo == pmop) {
+ if (lastpmop)
+ lastpmop->op_pmnext = pmop->op_pmnext;
+ else
+ HvPMROOT(pmstash) = pmop->op_pmnext;
+ break;
+ }
+ lastpmop = pmop;
+ pmop = pmop->op_pmnext;
+ }
+#ifdef USE_ITHREADS
+ Safefree(PmopSTASHPV(cPMOPo));
+#else
+ /* NOTE: PMOP.op_pmstash is not refcounted */
+#endif
+ }
+ }
cPMOPo->op_pmreplroot = Nullop;
ReREFCNT_dec(cPMOPo->op_pmregexp);
cPMOPo->op_pmregexp = (REGEXP*)NULL;
SvREFCNT_dec(cop->cop_io);
}
-STATIC void
-S_null(pTHX_ OP *o)
+void
+Perl_op_null(pTHX_ OP *o)
{
if (o->op_type == OP_NULL)
return;
switch (o->op_type) {
case OP_REPEAT:
- if (o->op_private & OPpREPEAT_DOLIST)
- null(((LISTOP*)cBINOPo->op_first)->op_first);
scalar(cBINOPo->op_first);
break;
case OP_OR:
else {
if (ckWARN(WARN_VOID)) {
useless = "a constant";
+ /* the constants 0 and 1 are permitted as they are
+ conventionally used as dummies in constructs like
+ 1 while some_condition_with_side_effects; */
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
else if (SvPOK(sv)) {
+ /* perl4's way of mixing documentation and code
+ (before the invention of POD) was based on a
+ trick to mix nroff and perl code. The trick was
+ built upon these three nroff macros being used in
+ void context. The pink camel has the details in
+ the script wrapman near page 319. */
if (strnEQ(SvPVX(sv), "di", 2) ||
strnEQ(SvPVX(sv), "ds", 2) ||
strnEQ(SvPVX(sv), "ig", 2))
}
}
}
- null(o); /* don't execute or even remember it */
+ op_null(o); /* don't execute or even remember it */
break;
case OP_POSTINC:
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
- null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
+ op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
else { /* lvalue subroutine call */
o->op_private |= OPpLVAL_INTRO;
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN) {
/* Backward compatibility mode: */
o->op_private |= OPpENTERSUB_INARGS;
if (!type && cUNOPo->op_first->op_type != OP_GV)
Perl_croak(aTHX_ "Can't localize through a reference");
if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
- PL_modcount = 10000;
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
return o; /* Treat \(@foo) like ordinary list. */
}
/* FALL THROUGH */
goto nomod;
ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
- case OP_AASSIGN:
case OP_ASLICE:
case OP_HSLICE:
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
+ /* FALL THROUGH */
+ case OP_AASSIGN:
case OP_NEXTSTATE:
case OP_DBSTATE:
- case OP_REFGEN:
case OP_CHOMP:
- PL_modcount = 10000;
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
case OP_RV2SV:
if (!type && cUNOPo->op_first->op_type != OP_GV)
case OP_PADAV:
case OP_PADHV:
- PL_modcount = 10000;
+ PL_modcount = RETURN_UNLIMITED_NUMBER;
if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
return o; /* Treat \(@foo) like ordinary list. */
if (scalar_mod_type(o, type))
goto nomod;
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
/* FALL THROUGH */
case OP_PADSV:
PL_modcount++;
/* FALL THROUGH */
case OP_POS:
case OP_VEC:
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
lvalue_func:
pad_free(o->op_targ);
o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
if (type == OP_ENTERSUB &&
!(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
o->op_private |= OPpLVAL_DEFER;
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
PL_modcount++;
break;
case OP_SCOPE:
case OP_LEAVE:
case OP_ENTER:
+ case OP_LINESEQ:
if (o->op_flags & OPf_KIDS)
mod(cLISTOPo->op_last, type);
break;
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
mod(kid, type);
break;
+
+ case OP_RETURN:
+ if (type != OP_LEAVESUBLV)
+ goto nomod;
+ break; /* mod()ing was handled by ck_return() */
}
- o->op_flags |= OPf_MOD;
+ if (type != OP_LEAVESUBLV)
+ o->op_flags |= OPf_MOD;
if (type == OP_AASSIGN || type == OP_SASSIGN)
o->op_flags |= OPf_SPECIAL|OPf_REF;
o->op_flags &= ~OPf_SPECIAL;
PL_hints |= HINT_BLOCK_SCOPE;
}
- else if (type != OP_GREPSTART && type != OP_ENTERSUB)
+ else if (type != OP_GREPSTART && type != OP_ENTERSUB
+ && type != OP_LEAVESUBLV)
o->op_flags |= OPf_REF;
return o;
}
o->op_type = OP_RV2CV; /* entersub => rv2cv */
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
- null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
+ op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
}
break;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+ if (attrs) {
+ GV *gv = cGVOPx_gv(cUNOPo->op_first);
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+ apply_attrs(GvSTASH(gv),
+ (type == OP_RV2SV ? GvSV(gv) :
+ type == OP_RV2AV ? (SV*)GvAV(gv) :
+ type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
+ attrs);
+ }
o->op_private |= OPpOUR_INTRO;
return o;
} else if (type != OP_PADSV &&
/* check for C<my Dog $spot> when deciding package */
namesvp = av_fetch(PL_comppad_name, o->op_targ, FALSE);
- if (namesvp && *namesvp && SvOBJECT(*namesvp) && HvNAME(SvSTASH(*namesvp)))
+ if (namesvp && *namesvp && (SvFLAGS(*namesvp) & SVpad_TYPED)
+ && HvNAME(SvSTASH(*namesvp)))
stash = SvSTASH(*namesvp);
else
stash = PL_curstash;
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
- null(kid);
+ op_null(kid);
}
else
o = newLISTOP(OP_SCOPE, 0, o, Nullop);
else {
if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
char *s;
- for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
+ for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
if (*s == ';' || *s == '=')
Perl_warner(aTHX_ WARN_PARENTHESIS,
"Parentheses missing around \"%s\" list",
case OP_SLE:
case OP_SGE:
case OP_SCMP:
-
- if (o->op_private & OPpLOCALE)
+ /* XXX what about the numeric ops? */
+ if (PL_hints & HINT_LOCALE)
goto nope;
}
if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
type != OP_NEGATE)
{
- IV iv = SvIV(sv);
- if ((NV)iv == SvNV(sv)) {
- SvREFCNT_dec(sv);
- sv = newSViv(iv);
- }
- else
- SvIOK_off(sv); /* undo SvIV() damage */
+#ifdef PERL_PRESERVE_IVUV
+ /* Only bother to attempt to fold to IV if
+ most operators will benefit */
+ SvIV_please(sv);
+#endif
}
return newSVOP(OP_CONST, 0, sv);
}
OP *
Perl_convert(pTHX_ I32 type, I32 flags, OP *o)
{
- OP *kid;
- OP *last = 0;
-
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, Nullop);
else
o->op_flags &= ~OPf_WANT;
if (!(PL_opargs[type] & OA_MARK))
- null(cLISTOPo->op_first);
+ op_null(cLISTOPo->op_first);
o->op_type = type;
o->op_ppaddr = PL_ppaddr[type];
if (o->op_type != type)
return o;
- if (cLISTOPo->op_children < 7) {
- /* XXX do we really need to do this if we're done appending?? */
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- last = kid;
- cLISTOPo->op_last = last; /* in case check substituted last arg */
- }
-
return fold_constants(o);
}
((LISTOP*)first)->op_first = last;
}
((LISTOP*)first)->op_last = last;
- ((LISTOP*)first)->op_children++;
return first;
}
first->op_last->op_sibling = last->op_first;
first->op_last = last->op_last;
- first->op_children += last->op_children;
- if (first->op_children)
- first->op_flags |= OPf_KIDS;
+ first->op_flags |= (last->op_flags & OPf_KIDS);
#ifdef PL_OP_SLAB_ALLOC
#else
if (type == OP_LIST) { /* already a PUSHMARK there */
first->op_sibling = ((LISTOP*)last)->op_first->op_sibling;
((LISTOP*)last)->op_first->op_sibling = first;
+ if (!(first->op_flags & OPf_PARENS))
+ last->op_flags &= ~OPf_PARENS;
}
else {
if (!(last->op_flags & OPf_KIDS)) {
first->op_sibling = ((LISTOP*)last)->op_first;
((LISTOP*)last)->op_first = first;
}
- ((LISTOP*)last)->op_children++;
+ last->op_flags |= OPf_KIDS;
return last;
}
{
if (!o || o->op_type != OP_LIST)
o = newLISTOP(OP_LIST, 0, o, Nullop);
- null(o);
+ op_null(o);
return o;
}
listop->op_type = type;
listop->op_ppaddr = PL_ppaddr[type];
- listop->op_children = (first != 0) + (last != 0);
+ if (first || last)
+ flags |= OPf_KIDS;
listop->op_flags = flags;
if (!last && first)
if (!last)
listop->op_last = pushop;
}
- else if (listop->op_children)
- listop->op_flags |= OPf_KIDS;
return (OP*)listop;
}
}
static int
-utf8compare(const void *a, const void *b)
-{
- int i;
- for (i = 0; i < 10; i++) {
- if ((*(U8**)a)[i] < (*(U8**)b)[i])
- return -1;
- if ((*(U8**)a)[i] > (*(U8**)b)[i])
- return 1;
- }
+uvcompare(const void *a, const void *b)
+{
+ if (*((UV *)a) < (*(UV *)b))
+ return -1;
+ if (*((UV *)a) > (*(UV *)b))
+ return 1;
+ if (*((UV *)a+1) < (*(UV *)b+1))
+ return -1;
+ if (*((UV *)a+1) > (*(UV *)b+1))
+ return 1;
return 0;
}
SV *rstr = ((SVOP*)repl)->op_sv;
STRLEN tlen;
STRLEN rlen;
- register U8 *t = (U8*)SvPV(tstr, tlen);
- register U8 *r = (U8*)SvPV(rstr, rlen);
+ U8 *t = (U8*)SvPV(tstr, tlen);
+ U8 *r = (U8*)SvPV(rstr, rlen);
register I32 i;
register I32 j;
I32 del;
I32 complement;
I32 squash;
+ I32 grows = 0;
register short *tbl;
+ PL_hints |= HINT_BLOCK_SCOPE;
complement = o->op_private & OPpTRANS_COMPLEMENT;
del = o->op_private & OPpTRANS_DELETE;
squash = o->op_private & OPpTRANS_SQUASH;
I32 none = 0;
U32 max = 0;
I32 bits;
- I32 grows = 0;
I32 havefinal = 0;
- U32 final;
+ U32 final = 0;
I32 from_utf = o->op_private & OPpTRANS_FROM_UTF;
I32 to_utf = o->op_private & OPpTRANS_TO_UTF;
+ U8* tsave = NULL;
+ U8* rsave = NULL;
+
+ if (!from_utf) {
+ STRLEN len = tlen;
+ tsave = t = bytes_to_utf8(t, &len);
+ tend = t + len;
+ }
+ if (!to_utf && rlen) {
+ STRLEN len = rlen;
+ rsave = r = bytes_to_utf8(r, &len);
+ rend = r + len;
+ }
+
+/* There are several snags with this code on EBCDIC:
+ 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
+ 2. scan_const() in toke.c has encoded chars in native encoding which makes
+ ranges at least in EBCDIC 0..255 range the bottom odd.
+*/
if (complement) {
U8 tmpbuf[UTF8_MAXLEN+1];
- U8** cp;
- I32* cl;
+ UV *cp;
UV nextmin = 0;
- New(1109, cp, tlen, U8*);
+ New(1109, cp, 2*tlen, UV);
i = 0;
transv = newSVpvn("",0);
while (t < tend) {
- cp[i++] = t;
- t += UTF8SKIP(t);
- if (*t == 0xff) {
+ cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ t += ulen;
+ if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
t++;
- t += UTF8SKIP(t);
+ cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
+ t += ulen;
+ }
+ else {
+ cp[2*i+1] = cp[2*i];
}
+ i++;
}
- qsort(cp, i, sizeof(U8*), utf8compare);
+ qsort(cp, i, 2*sizeof(UV), uvcompare);
for (j = 0; j < i; j++) {
- U8 *s = cp[j];
- I32 cur = j < i ? cp[j+1] - s : tend - s;
- UV val = utf8_to_uv(s, cur, &ulen, 0);
- s += ulen;
+ UV val = cp[2*j];
diff = val - nextmin;
if (diff > 0) {
- t = uv_to_utf8(tmpbuf,nextmin);
+ t = uvuni_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
if (diff > 1) {
- t = uv_to_utf8(tmpbuf, val - 1);
- sv_catpvn(transv, "\377", 1);
+ U8 range_mark = UTF_TO_NATIVE(0xff);
+ t = uvuni_to_utf8(tmpbuf, val - 1);
+ sv_catpvn(transv, (char *)&range_mark, 1);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
}
}
- if (*s == 0xff)
- val = utf8_to_uv(s+1, cur - 1, &ulen, 0);
+ val = cp[2*j+1];
if (val >= nextmin)
nextmin = val + 1;
}
- t = uv_to_utf8(tmpbuf,nextmin);
+ t = uvuni_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
- t = uv_to_utf8(tmpbuf, 0x7fffffff);
- sv_catpvn(transv, "\377", 1);
+ {
+ U8 range_mark = UTF_TO_NATIVE(0xff);
+ sv_catpvn(transv, (char *)&range_mark, 1);
+ }
+ t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
t = (U8*)SvPVX(transv);
tlen = SvCUR(transv);
tend = t + tlen;
+ Safefree(cp);
}
else if (!rlen && !del) {
r = t; rlen = tlen; rend = tend;
}
if (!squash) {
- if (t == r ||
+ if ((!rlen && !del) || t == r ||
(tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
{
o->op_private |= OPpTRANS_IDENTICAL;
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
+ tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
t += ulen;
- if (t < tend && *t == 0xff) { /* illegal utf8 val indicates range */
+ if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
t++;
- tlast = (I32)utf8_to_uv(t, tend - t, &ulen, 0);
+ tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, 0);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
+ rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
r += ulen;
- if (r < rend && *r == 0xff) { /* illegal utf8 val indicates range */
+ if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
r++;
- rlast = (I32)utf8_to_uv(r, rend - r, &ulen, 0);
+ rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, 0);
r += ulen;
}
else
if (rfirst + diff > max)
max = rfirst + diff;
+ if (!grows)
+ grows = (tfirst < rfirst &&
+ UNISKIP(tfirst) < UNISKIP(rfirst + diff));
rfirst += diff + 1;
- if (!grows) {
- if (rfirst <= 0x80)
- ;
- else if (rfirst <= 0x800)
- grows |= (tfirst < 0x80);
- else if (rfirst <= 0x10000)
- grows |= (tfirst < 0x800);
- else if (rfirst <= 0x200000)
- grows |= (tfirst < 0x10000);
- else if (rfirst <= 0x4000000)
- grows |= (tfirst < 0x200000);
- else if (rfirst <= 0x80000000)
- grows |= (tfirst < 0x4000000);
- }
}
tfirst += diff + 1;
}
else
bits = 8;
+ Safefree(cPVOPo->op_pv);
cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none);
SvREFCNT_dec(listsv);
if (transv)
SvREFCNT_dec(transv);
- if (!del && havefinal)
+ if (!del && havefinal && rlen)
(void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
newSVuv((UV)final), 0);
- if (grows && to_utf)
+ if (grows)
o->op_private |= OPpTRANS_GROWS;
+ if (tsave)
+ Safefree(tsave);
+ if (rsave)
+ Safefree(rsave);
+
op_free(expr);
op_free(repl);
return o;
else
tbl[i] = i;
}
- else
+ else {
+ if (i < 128 && r[j] >= 128)
+ grows = 1;
tbl[i] = r[j++];
+ }
}
}
+ if (!del) {
+ if (!rlen) {
+ j = rlen;
+ if (!squash)
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
+ else if (j >= rlen)
+ j = rlen - 1;
+ else
+ cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
+ tbl[0x100] = rlen - j;
+ for (i=0; i < rlen - j; i++)
+ tbl[0x101+i] = r[j+i];
+ }
}
else {
if (!rlen && !del) {
}
--j;
}
- if (tbl[t[i]] == -1)
+ if (tbl[t[i]] == -1) {
+ if (t[i] < 128 && r[j] >= 128)
+ grows = 1;
tbl[t[i]] = r[j];
+ }
}
}
+ if (grows)
+ o->op_private |= OPpTRANS_GROWS;
op_free(expr);
op_free(repl);
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
HvPMROOT(PL_curstash) = pmop;
+ PmopSTASH_set(pmop,PL_curstash);
}
return (OP*)pmop;
Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
{
OP *pack;
- OP *rqop;
OP *imop;
OP *veop;
- GV *gv;
if (id->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
newSVOP(OP_METHOD_NAMED, 0, meth)));
}
- /* Fake up a require, handle override, if any */
- gv = gv_fetchpv("require", FALSE, SVt_PVCV);
- if (!(gv && GvIMPORTED_CV(gv)))
- gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
-
- if (gv && GvIMPORTED_CV(gv)) {
- rqop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
- append_elem(OP_LIST, id,
- scalar(newUNOP(OP_RV2CV, 0,
- newGVOP(OP_GV, 0,
- gv))))));
- }
- else {
- rqop = newUNOP(OP_REQUIRE, 0, id);
- }
-
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
Nullop,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
- newSTATEOP(0, Nullch, rqop),
+ newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
PL_expect = XSTATE;
}
+/*
+=for apidoc load_module
+
+Loads the module whose name is pointed to by the string part of name.
+Note that the actual module name, not its filename, should be given.
+Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of
+PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS
+(or 0 for no flags). ver, if specified, provides version semantics
+similar to C<use Foo::Bar VERSION>. The optional trailing SV*
+arguments can be used to specify arguments to the module's import()
+method, similar to C<use Foo::Bar VERSION LIST>.
+
+=cut */
+
void
Perl_load_module(pTHX_ U32 flags, SV *name, SV *ver, ...)
{
}
}
else {
- if (PL_modcount < 10000 &&
+ if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
((LISTOP*)right)->op_last->op_type == OP_CONST)
{
SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = flags;
- cop->op_private = (PL_hints & HINT_BYTE);
+ cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
if (cont) {
next = LINKLIST(cont);
- loopflags |= OPpLOOP_CONTINUE;
}
if (expr) {
OP *unstack = newOP(OP_UNSTACK, 0);
op_free(expr);
expr = (OP*)(listop);
- null(expr);
+ op_null(expr);
iterflags |= OPf_STACKED;
}
else {
SAVEVPTR(PL_curpad);
PL_curpad = 0;
- if (!CvCLONED(cv))
- op_free(CvROOT(cv));
+ op_free(CvROOT(cv));
CvROOT(cv) = Nullop;
LEAVE;
}
SvPOK_off((SV*)cv); /* forget prototype */
- CvFLAGS(cv) = 0;
- SvREFCNT_dec(CvGV(cv));
CvGV(cv) = Nullgv;
- SvREFCNT_dec(CvOUTSIDE(cv));
+ /* Since closure prototypes have the same lifetime as the containing
+ * 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))))
+ {
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ }
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
}
CvPADLIST(cv) = Nullav;
}
+ if (CvXSUB(cv)) {
+ CvXSUB(cv) = 0;
+ }
+ CvFLAGS(cv) = 0;
}
+#ifdef DEBUG_CLOSURES
STATIC void
S_cv_dump(pTHX_ CV *cv)
{
}
#endif /* DEBUGGING */
}
+#endif /* DEBUG_CLOSURES */
STATIC CV *
S_cv_clone2(pTHX_ CV *proto, CV *outside)
CvOWNER(cv) = 0;
#endif /* USE_THREADS */
CvFILE(cv) = CvFILE(proto);
- CvGV(cv) = (GV*)SvREFCNT_inc(CvGV(proto));
+ CvGV(cv) = CvGV(proto);
CvSTASH(cv) = CvSTASH(proto);
- CvROOT(cv) = CvROOT(proto);
+ CvROOT(cv) = OpREFCNT_inc(CvROOT(proto));
CvSTART(cv) = CvSTART(proto);
if (outside)
CvOUTSIDE(cv) = (CV*)SvREFCNT_inc(outside);
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);
+ }
+#endif
+
if (!block || !ps || *ps || attrs)
const_sv = Nullsv;
else
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);
+ }
+#endif
+
/* if the subroutine doesn't exist and wasn't pre-declared
* with a prototype, assume it will be AUTOLOADed,
* skipping the prototype check
CvOUTSIDE(PL_compcv) = 0;
CvPADLIST(cv) = CvPADLIST(PL_compcv);
CvPADLIST(PL_compcv) = 0;
- if (SvREFCNT(PL_compcv) > 1) /* XXX Make closures transit through stub. */
- CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc((SV*)cv);
+ /* inner references to PL_compcv must be fixed up ... */
+ {
+ AV *padlist = CvPADLIST(cv);
+ AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+ AV *comppad = (AV*)AvARRAY(padlist)[1];
+ SV **namepad = AvARRAY(comppad_name);
+ SV **curpad = AvARRAY(comppad);
+ for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+ SV *namesv = namepad[ix];
+ if (namesv && namesv != &PL_sv_undef
+ && *SvPVX(namesv) == '&')
+ {
+ CV *innercv = (CV*)curpad[ix];
+ if (CvOUTSIDE(innercv) == PL_compcv) {
+ CvOUTSIDE(innercv) = cv;
+ if (!CvANON(innercv) || CvCLONED(innercv)) {
+ (void)SvREFCNT_inc(cv);
+ SvREFCNT_dec(PL_compcv);
+ }
+ }
+ }
+ }
+ }
+ /* ... before we throw it away */
SvREFCNT_dec(PL_compcv);
}
else {
PL_sub_generation++;
}
}
- CvGV(cv) = (GV*)SvREFCNT_inc(gv);
+ CvGV(cv) = gv;
CvFILE(cv) = CopFILE(PL_curcop);
CvSTASH(cv) = PL_curstash;
#ifdef USE_THREADS
av_store(PL_comppad_name, AvFILLp(PL_comppad), Nullsv);
if (CvLVALUE(cv)) {
- CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, scalarseq(block));
+ CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
+ mod(scalarseq(block), OP_LEAVESUBLV));
}
else {
CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
}
+ /* If a potential closure prototype, don't keep a refcount on
+ * outer CV, unless the latter happens to be a passing eval"".
+ * 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))))
+ {
+ SvREFCNT_dec(CvOUTSIDE(cv));
+ }
+
if (name || aname) {
char *s;
char *tname = (name ? name : aname);
PL_sub_generation++;
}
}
- CvGV(cv) = (GV*)SvREFCNT_inc(gv);
+ CvGV(cv) = gv;
#ifdef USE_THREADS
New(666, CvMUTEXP(cv), 1, perl_mutex);
MUTEX_INIT(CvMUTEXP(cv));
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)");
+ }
+#endif
GvMULTI_on(gv);
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
}
cv = PL_compcv;
GvFORM(gv) = cv;
- CvGV(cv) = (GV*)SvREFCNT_inc(gv);
+ CvGV(cv) = gv;
CvFILE(cv) = CopFILE(PL_curcop);
for (ix = AvFILLp(PL_comppad); ix > 0; ix--) {
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return o;
}
+ else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
+ && ckWARN(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "Using an array as a reference is deprecated");
+ }
return newUNOP(OP_RV2AV, 0, scalar(o));
}
o->op_ppaddr = PL_ppaddr[OP_PADHV];
return o;
}
+ else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
+ && ckWARN(WARN_DEPRECATED)) {
+ Perl_warner(aTHX_ WARN_DEPRECATED,
+ "Using a hash as a reference is deprecated");
+ }
return newUNOP(OP_RV2HV, 0, scalar(o));
}
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
PL_op_desc[o->op_type]);
}
- null(kid);
+ op_null(kid);
}
return o;
}
if (!kid) {
o->op_flags &= ~OPf_KIDS;
- null(o);
+ op_null(o);
}
else if (kid->op_type == OP_LINESEQ) {
LOGOP *enter;
o = ck_fun(o);
kid = cUNOPo->op_first->op_sibling;
if (kid->op_type == OP_RV2GV)
- null(kid);
+ op_null(kid);
}
else
o = listkids(o);
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]);
- null(kid);
+ op_null(kid);
}
return o;
}
#else
kid->op_sv = SvREFCNT_inc(gv);
#endif
+ kid->op_private = 0;
kid->op_ppaddr = PL_ppaddr[OP_GV];
}
}
else
o = newUNOP(type, 0, newDEFSVOP());
}
-#ifdef USE_LOCALE
- if (type == OP_FTTEXT || type == OP_FTBINARY) {
- o->op_private = 0;
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
- }
-#endif
return o;
}
list(kid);
break;
case OA_AVREF:
+ if ((type == OP_PUSH || type == OP_UNSHIFT)
+ && !kid->op_sibling && ckWARN(WARN_SYNTAX))
+ 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))
{
#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_ 0, newSVpvn("File::Glob", 10), Nullsv,
- /* null-terminated import list */
- newSVpvn(":globally", 9), 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);
+ SvREFCNT_inc((SV*)GvCV(gv));
+ GvIMPORTED_CV_on(gv);
LEAVE;
}
#endif /* PERL_EXTERNAL_GLOB */
if (!kid)
append_elem(o->op_type, o, newDEFSVOP());
- o = listkids(o);
-
- o->op_private = 0;
-#ifdef USE_LOCALE
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
-#endif
-
- return o;
-}
-
-OP *
-Perl_ck_fun_locale(pTHX_ OP *o)
-{
- o = ck_fun(o);
-
- o->op_private = 0;
-#ifdef USE_LOCALE
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
-#endif
-
- return o;
+ return listkids(o);
}
OP *
}
OP *
-Perl_ck_scmp(pTHX_ OP *o)
-{
- o->op_private = 0;
-#ifdef USE_LOCALE
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
-#endif
-
- return o;
-}
-
-OP *
Perl_ck_match(pTHX_ OP *o)
{
o->op_private |= OPpRUNTIME;
OP *
Perl_ck_require(pTHX_ OP *o)
{
+ GV* gv;
+
if (o->op_flags & OPf_KIDS) { /* Shall we supply missing .pm? */
SVOP *kid = (SVOP*)cUNOPo->op_first;
sv_catpvn(kid->op_sv, ".pm", 3);
}
}
+
+ /* handle override, if any */
+ gv = gv_fetchpv("require", FALSE, SVt_PVCV);
+ if (!(gv && GvIMPORTED_CV(gv)))
+ gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
+
+ if (gv && GvIMPORTED_CV(gv)) {
+ OP *kid = cUNOPo->op_first;
+ cUNOPo->op_first = 0;
+ op_free(o);
+ return ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
+ append_elem(OP_LIST, kid,
+ scalar(newUNOP(OP_RV2CV, 0,
+ newGVOP(OP_GV, 0,
+ gv))))));
+ }
+
return ck_fun(o);
}
+OP *
+Perl_ck_return(pTHX_ OP *o)
+{
+ OP *kid;
+ if (CvLVALUE(PL_compcv)) {
+ for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+ mod(kid, OP_LEAVESUBLV);
+ }
+ return o;
+}
+
#if 0
OP *
Perl_ck_retarget(pTHX_ OP *o)
Perl_ck_sort(pTHX_ OP *o)
{
OP *firstkid;
- o->op_private = 0;
-#ifdef USE_LOCALE
- if (PL_hints & HINT_LOCALE)
- o->op_private |= OPpLOCALE;
-#endif
if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
if (o->op_flags & OPf_STACKED) { /* may have been cleared */
- OP *k;
+ OP *k = NULL;
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
}
else if (kid->op_type == OP_LEAVE) {
if (o->op_type == OP_SORT) {
- null(kid); /* wipe out leave */
+ op_null(kid); /* wipe out leave */
kid->op_next = kid;
for (k = kLISTOP->op_first->op_next; k; k = k->op_next) {
o->op_flags |= OPf_SPECIAL;
}
else if (kid->op_type == OP_RV2SV || kid->op_type == OP_PADSV)
- null(firstkid);
+ op_null(firstkid);
firstkid = firstkid->op_sibling;
}
kid = cLISTOPo->op_first->op_sibling;
cLISTOPo->op_first->op_sibling = kid->op_sibling; /* bypass old block */
op_free(kid); /* then delete it */
- cLISTOPo->op_children--;
}
OP *
if (cvop->op_type == OP_RV2CV) {
SVOP* tmpop;
o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
- null(cvop); /* disable rv2cv */
+ op_null(cvop); /* disable rv2cv */
tmpop = (SVOP*)((UNOP*)cvop)->op_first;
if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
GV *gv = cGVOPx_gv(tmpop);
{
register OP* oldop = 0;
STRLEN n_a;
- OP *last_composite = Nullop;
if (!o || o->op_seq)
return;
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
o->op_seq = PL_op_seqmax++;
- last_composite = Nullop;
break;
case OP_CONST:
o->op_private |= OPpTARGET_MY;
}
}
- null(o->op_next);
+ op_null(o->op_next);
}
ignore_optimization:
o->op_seq = PL_op_seqmax++;
case OP_GV:
if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
- null(o->op_next);
+ op_null(o->op_next);
o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
| OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
(PL_op = pop->op_next) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
- (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF)) &&
- (i = SvIV(((SVOP*)pop)->op_sv) - PL_compiling.cop_arybase)
+ (OPpLVAL_INTRO|OPpLVAL_DEFER|OPpDEREF|OPpMAYBE_LVSUB)) &&
+ (i = SvIV(((SVOP*)pop)->op_sv) - PL_curcop->cop_arybase)
<= 255 &&
i >= 0)
{
GV *gv;
- null(o->op_next);
- null(pop->op_next);
- null(pop);
+ op_null(o->op_next);
+ op_null(pop->op_next);
+ op_null(pop);
o->op_flags |= pop->op_next->op_flags & OPf_MOD;
o->op_next = pop->op_next->op_next;
o->op_type = OP_AELEMFAST;
break;
case OP_ENTERLOOP:
+ case OP_ENTERITER:
o->op_seq = PL_op_seqmax++;
+ while (cLOOP->op_redoop->op_type == OP_NULL)
+ cLOOP->op_redoop = cLOOP->op_redoop->op_next;
peep(cLOOP->op_redoop);
+ while (cLOOP->op_nextop->op_type == OP_NULL)
+ cLOOP->op_nextop = cLOOP->op_nextop->op_next;
peep(cLOOP->op_nextop);
+ while (cLOOP->op_lastop->op_type == OP_NULL)
+ cLOOP->op_lastop = cLOOP->op_lastop->op_next;
peep(cLOOP->op_lastop);
break;
case OP_MATCH:
case OP_SUBST:
o->op_seq = PL_op_seqmax++;
+ while (cPMOP->op_pmreplstart &&
+ cPMOP->op_pmreplstart->op_type == OP_NULL)
+ cPMOP->op_pmreplstart = cPMOP->op_pmreplstart->op_next;
peep(cPMOP->op_pmreplstart);
break;
svp = cSVOPx_svp(((BINOP*)o)->op_last);
if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
key = SvPV(sv, keylen);
- lexname = newSVpvn_share(key, keylen, 0);
if (SvUTF8(sv))
- SvUTF8_on(lexname);
+ keylen = -keylen;
+ lexname = newSVpvn_share(key, keylen, 0);
SvREFCNT_dec(sv);
*svp = lexname;
}
if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!SvOBJECT(lexname))
+ if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
if (!fields || !GvHV(*fields))
break;
key = SvPV(*svp, keylen);
+ if (SvUTF8(*svp))
+ keylen = -keylen;
indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
break;
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
- if (!SvOBJECT(lexname))
+ if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
if (!fields || !GvHV(*fields))
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);
if (!indsvp) {
Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
break;
}
- case OP_RV2AV:
- case OP_RV2HV:
- if (!(o->op_flags & OPf_WANT)
- || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
- {
- last_composite = o;
- }
- o->op_seq = PL_op_seqmax++;
- break;
-
- case OP_RETURN:
- if (o->op_next && o->op_next->op_type != OP_LEAVESUBLV) {
- o->op_seq = PL_op_seqmax++;
- break;
- }
- /* FALL THROUGH */
-
- case OP_LEAVESUBLV:
- if (last_composite) {
- OP *r = last_composite;
-
- while (r->op_sibling)
- r = r->op_sibling;
- if (r->op_next == o
- || (r->op_next->op_type == OP_LIST
- && r->op_next->op_next == o))
- {
- if (last_composite->op_type == OP_RV2AV)
- yyerror("Lvalue subs returning arrays not implemented yet");
- else
- yyerror("Lvalue subs returning hashes not implemented yet");
- ;
- }
- }
- /* FALL THROUGH */
-
default:
o->op_seq = PL_op_seqmax++;
break;
const_sv_xsub(pTHXo_ CV* cv)
{
dXSARGS;
+ if (items != 0) {
+#if 0
+ Perl_croak(aTHX_ "usage: %s::%s()",
+ HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
+#endif
+ }
EXTEND(sp, 1);
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
+
https://perl5.git.perl.org / perl5.git / blobdiff