/* op.c
*
- * Copyright (c) 1991-1999, Larry Wall
+ * Copyright (c) 1991-2000, 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.
if (kid->op_type == OP_METHOD_NAMED
|| kid->op_type == OP_METHOD)
{
- OP *newop;
+ UNOP *newop;
if (kid->op_sibling || kid->op_next != kid) {
yyerror("panic: unexpected optree near method call");
break;
}
- NewOp(1101, newop, 1, OP);
+ NewOp(1101, newop, 1, UNOP);
newop->op_type = OP_RV2CV;
newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
- newop->op_next = newop;
- kid->op_sibling = newop;
+ newop->op_first = Nullop;
+ newop->op_next = (OP*)newop;
+ kid->op_sibling = (OP*)newop;
newop->op_private |= OPpLVAL_INTRO;
break;
}
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
+ if ((PL_hints & HINT_UTF8) || (SvUTF8(pat) && !(PL_hints & HINT_BYTE)))
+ pm->op_pmdynflags |= PMdf_UTF8;
pm->op_pmregexp = CALLREGCOMP(aTHX_ p, p + plen, pm);
if (strEQ("\\s+", pm->op_pmregexp->precomp))
pm->op_pmflags |= PMf_WHITE;
op_free(expr);
}
else {
+ if (PL_hints & HINT_UTF8)
+ pm->op_pmdynflags |= PMdf_UTF8;
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
? OP_REGCRESET
veop = Nullop;
- if(version != Nullop) {
+ if (version != Nullop) {
SV *vesv = ((SVOP*)version)->op_sv;
if (arg == Nullop && !SvNIOK(vesv)) {
}
else {
OP *pack;
+ SV *meth;
if (version->op_type != OP_CONST || !SvNIOK(vesv))
Perl_croak(aTHX_ "Version number must be constant number");
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
/* Fake up a method call to VERSION */
+ meth = newSVpvn("VERSION",7);
+ sv_upgrade(meth, SVt_PVIV);
+ SvIOK_on(meth);
+ PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
- prepend_elem(OP_LIST, pack, list(version)),
- newSVOP(OP_METHOD_NAMED, 0,
- newSVpvn("VERSION", 7))));
+ prepend_elem(OP_LIST, pack, list(version)),
+ newSVOP(OP_METHOD_NAMED, 0, meth)));
}
}
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB)
imop = arg; /* no import on explicit () */
- else if(SvNIOK(((SVOP*)id)->op_sv)) {
+ else if (SvNIOK(((SVOP*)id)->op_sv)) {
imop = Nullop; /* use 5.0; */
}
else {
+ SV *meth;
+
/* Make copy of id so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+
+ /* Fake up a method call to import/unimport */
+ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
+ sv_upgrade(meth, SVt_PVIV);
+ SvIOK_on(meth);
+ PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
- append_elem(OP_LIST,
- prepend_elem(OP_LIST, pack, list(arg)),
- newSVOP(OP_METHOD_NAMED, 0,
- aver ? newSVpvn("import", 6)
- : newSVpvn("unimport", 8))));
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, pack, list(arg)),
+ newSVOP(OP_METHOD_NAMED, 0, meth)));
}
/* Fake up a require, handle override, if any */
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
cop->op_flags = flags;
- cop->op_private = (PL_hints & HINT_UTF8);
+ cop->op_private = (PL_hints & HINT_BYTE);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
}
}
if (first->op_type == OP_CONST) {
- if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE))
- Perl_warner(aTHX_ WARN_PRECEDENCE, "Probable precedence problem on %s",
- PL_op_desc[type]);
+ if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
+ Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
assert(!CvUNIQUE(proto));
ENTER;
- SAVEVPTR(PL_curpad);
- SAVESPTR(PL_comppad);
+ SAVECOMPPAD();
SAVESPTR(PL_comppad_name);
SAVESPTR(PL_compcv);
{
SV *sv = Nullsv;
- if(!o)
+ if (!o)
return Nullsv;
- if(o->op_type == OP_LINESEQ && cLISTOPo->op_first)
+ if (o->op_type == OP_LINESEQ && cLISTOPo->op_first)
o = cLISTOPo->op_first->op_sibling;
for (; o; o = o->op_next) {
{
dTHR;
STRLEN n_a;
- char *name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
- GV *gv = gv_fetchpv(name ? name : "__ANON__",
- GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
- SVt_PVCV);
+ char *name;
+ char *aname;
+ GV *gv;
char *ps = proto ? SvPVx(((SVOP*)proto)->op_sv, n_a) : Nullch;
register CV *cv=0;
I32 ix;
+ 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"]",
+ CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
+ aname = SvPVX(sv);
+ }
+ else
+ aname = Nullch;
+ gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
+ GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
+ SVt_PVCV);
+
if (o)
SAVEFREEOP(o);
if (proto)
Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
if (!block)
goto withattrs;
- if(const_sv = cv_const_sv(cv))
+ if (const_sv = cv_const_sv(cv))
const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)
&& !(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
- "autouse"))) {
+ "autouse")))
+ {
line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, PL_copline);
Perl_warner(aTHX_ WARN_REDEFINE,
}
}
- if (name) {
+ if (name || aname) {
char *s;
+ char *tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV *sv = NEWSV(0,0);
SV *tmpstr = sv_newmortal();
GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
- CV *cv;
+ CV *pcv;
HV *hv;
+ char *t;
Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
CopFILE(PL_curcop),
hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX(tmpstr), SvCUR(tmpstr))
- && (cv = GvCV(db_postponed))) {
+ && (pcv = GvCV(db_postponed)))
+ {
dSP;
PUSHMARK(SP);
XPUSHs(tmpstr);
PUTBACK;
- call_sv((SV*)cv, G_DISCARD);
+ call_sv((SV*)pcv, G_DISCARD);
}
}
- if ((s = strrchr(name,':')))
+ if ((s = strrchr(tname,':')))
s++;
else
- s = name;
+ s = tname;
if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
goto done;
}
/* XXX unsafe for threads if eval_owner isn't held */
+/*
+=for apidoc newCONSTSUB
+
+Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
+eligible for inlining at compile-time.
+
+=cut
+*/
+
void
Perl_newCONSTSUB(pTHX_ HV *stash, char *name, SV *sv)
{
LEAVE;
}
+/*
+=for apidoc U||newXS
+
+Used by C<xsubpp> to hook up XSUBs as Perl subs.
+
+=cut
+*/
+
CV *
Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
{
OP *kid = cLISTOPo->op_first;
/* has a disposable target? */
if ((PL_opargs[kid->op_type] & OA_TARGLEX)
- && !(kid->op_flags & OPf_STACKED))
+ && !(kid->op_flags & OPf_STACKED)
+ /* Cannot steal the second time! */
+ && !(kid->op_private & OPpTARGET_MY))
{
OP *kkid = kid->op_sibling;
return;
if (strEQ(GvNAME(gv), "a"))
reversed = 0;
- else if(strEQ(GvNAME(gv), "b"))
+ else if (strEQ(GvNAME(gv), "b"))
reversed = 1;
else
return;
UNOP *rop;
SV *lexname;
GV **fields;
- SV **svp, **indsvp;
+ SV **svp, **indsvp, *sv;
I32 ind;
char *key;
STRLEN keylen;
+ o->op_seq = PL_op_seqmax++;
if ((o->op_private & (OPpLVAL_INTRO))
|| ((BINOP*)o)->op_last->op_type != OP_CONST)
break;
rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
o->op_type = OP_AELEM;
o->op_ppaddr = PL_ppaddr[OP_AELEM];
+ sv = newSViv(ind);
+ if (SvREADONLY(*svp))
+ SvREADONLY_on(sv);
+ SvFLAGS(sv) |= (SvFLAGS(*svp)
+ & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
SvREFCNT_dec(*svp);
- *svp = newSViv(ind);
+ *svp = sv;
+ break;
+ }
+
+ case OP_HSLICE: {
+ UNOP *rop;
+ SV *lexname;
+ GV **fields;
+ SV **svp, **indsvp, *sv;
+ I32 ind;
+ char *key;
+ STRLEN keylen;
+ SVOP *first_key_op, *key_op;
+
+ o->op_seq = PL_op_seqmax++;
+ if ((o->op_private & (OPpLVAL_INTRO))
+ /* I bet there's always a pushmark... */
+ || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
+ /* hmmm, no optimization if list contains only one key. */
+ break;
+ rop = (UNOP*)((LISTOP*)o)->op_last;
+ 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))
+ break;
+ fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ if (!fields || !GvHV(*fields))
+ break;
+ /* Again guessing that the pushmark can be jumped over.... */
+ first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
+ ->op_first->op_sibling;
+ /* Check that the key list contains only constants. */
+ for (key_op = first_key_op; key_op;
+ key_op = (SVOP*)key_op->op_sibling)
+ if (key_op->op_type != OP_CONST)
+ break;
+ if (key_op)
+ break;
+ rop->op_type = OP_RV2AV;
+ rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ o->op_type = OP_ASLICE;
+ o->op_ppaddr = PL_ppaddr[OP_ASLICE];
+ for (key_op = first_key_op; key_op;
+ key_op = (SVOP*)key_op->op_sibling) {
+ svp = cSVOPx_svp(key_op);
+ key = SvPV(*svp, 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",
+ key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
+ }
+ ind = SvIV(*indsvp);
+ if (ind < 1)
+ Perl_croak(aTHX_ "Bad index while coercing array into hash");
+ sv = newSViv(ind);
+ if (SvREADONLY(*svp))
+ SvREADONLY_on(sv);
+ SvFLAGS(sv) |= (SvFLAGS(*svp)
+ & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
+ SvREFCNT_dec(*svp);
+ *svp = sv;
+ }
break;
}
projects / p5sagit/p5-mst-13.2.git / blobdiff