/* 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 (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) {
SV **svp = AvARRAY(PL_comppad_name);
- for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) {
+ HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
+ PADOFFSET top = AvFILLp(PL_comppad_name);
+ for (off = top; off > PL_comppad_name_floor; off--) {
if ((sv = svp[off])
&& sv != &PL_sv_undef
&& (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
+ && (PL_in_my != KEY_our
+ || ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
&& strEQ(name, SvPVX(sv)))
{
- if (PL_in_my != KEY_our
- || GvSTASH(sv) == (PL_curstash ? PL_curstash : PL_defstash))
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "\"%s\" variable %s masks earlier declaration in same %s",
+ (PL_in_my == KEY_our ? "our" : "my"),
+ name,
+ (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
+ --off;
+ break;
+ }
+ }
+ if (PL_in_my == KEY_our) {
+ while (off >= 0 && off <= top) {
+ if ((sv = svp[off])
+ && sv != &PL_sv_undef
+ && ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
+ && strEQ(name, SvPVX(sv)))
{
Perl_warner(aTHX_ WARN_UNSAFE,
- "\"%s\" variable %s masks earlier declaration in same %s",
- (PL_in_my == KEY_our ? "our" : "my"),
- name,
- (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
+ "\"our\" variable %s redeclared", name);
+ Perl_warner(aTHX_ WARN_UNSAFE,
+ "(Did you mean \"local\" instead of \"our\"?)\n");
+ break;
}
- break;
+ --off;
}
}
}
sv_setpv(sv, name);
if (PL_in_my_stash) {
if (*name != '$')
- yyerror(Perl_form(aTHX_ "Can't declare class for non-scalar %s in \"my\"",
- 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);
(void)SvUPGRADE(sv, SVt_PVMG);
SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
case OP_GGRGID:
case OP_GETLOGIN:
func_ops:
- if (!(o->op_private & OPpLVAL_INTRO))
+ if (!(o->op_private & (OPpLVAL_INTRO|OPpOUR_INTRO)))
useless = PL_op_desc[o->op_type];
break;
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;
}
type != OP_PADHV &&
type != OP_PUSHMARK)
{
- yyerror(Perl_form(aTHX_ "Can't declare %s in my", PL_op_desc[o->op_type]));
+ yyerror(Perl_form(aTHX_ "Can't declare %s in \"%s\"",
+ PL_op_desc[o->op_type],
+ PL_in_my == KEY_our ? "our" : "my"));
return o;
}
else if (attrs && type != OP_PUSHMARK) {
SV *padsv;
SV **namesvp;
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+
/* 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 (o->op_flags & OPf_PARENS)
list(o);
- PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
if (attrs)
SAVEFREEOP(attrs);
- return my_kid(o, attrs);
+ o = my_kid(o, attrs);
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+ return o;
}
OP *
char *s;
for (s = PL_bufptr; *s && (isALNUM(*s) || (*s & 0x80) || strchr("@$%, ",*s)); s++) ;
if (*s == ';' || *s == '=')
- Perl_warner(aTHX_ WARN_PARENTHESIS, "Parentheses missing around \"%s\" list",
- lex ? "my" : "local");
+ Perl_warner(aTHX_ WARN_PARENTHESIS,
+ "Parentheses missing around \"%s\" list",
+ lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
}
}
- PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
if (lex)
- return my(o);
+ o = my(o);
else
- return mod(o, OP_NULL); /* a bit kludgey */
+ o = mod(o, OP_NULL); /* a bit kludgey */
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+ return o;
}
OP *
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;
if (!block)
block = newOP(OP_NULL, 0);
+ else if (cont) {
+ block = scope(block);
+ }
if (cont)
next = LINKLIST(cont);
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 != 'S' && *s != 'I')
+ if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
goto done;
if (strEQ(s, "BEGIN")) {
av_store(PL_endav, 0, SvREFCNT_inc(cv));
GvCV(gv) = 0;
}
- else if (strEQ(s, "STOP") && !PL_error_count) {
- if (!PL_stopav)
- PL_stopav = newAV();
+ else if (strEQ(s, "CHECK") && !PL_error_count) {
+ if (!PL_checkav)
+ PL_checkav = newAV();
DEBUG_x( dump_sub(gv) );
- av_unshift(PL_stopav, 1);
- av_store(PL_stopav, 0, SvREFCNT_inc(cv));
+ av_unshift(PL_checkav, 1);
+ av_store(PL_checkav, 0, SvREFCNT_inc(cv));
GvCV(gv) = 0;
}
else if (strEQ(s, "INIT") && !PL_error_count) {
}
/* 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)
{
else
s = name;
- if (*s != 'B' && *s != 'E' && *s != 'S' && *s != 'I')
+ if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
goto done;
if (strEQ(s, "BEGIN")) {
av_store(PL_endav, 0, SvREFCNT_inc(cv));
GvCV(gv) = 0;
}
- else if (strEQ(s, "STOP")) {
- if (!PL_stopav)
- PL_stopav = newAV();
- av_unshift(PL_stopav, 1);
- av_store(PL_stopav, 0, SvREFCNT_inc(cv));
+ else if (strEQ(s, "CHECK")) {
+ if (!PL_checkav)
+ PL_checkav = newAV();
+ av_unshift(PL_checkav, 1);
+ av_store(PL_checkav, 0, SvREFCNT_inc(cv));
GvCV(gv) = 0;
}
else if (strEQ(s, "INIT")) {
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;
if (o->op_next->op_type == OP_RV2SV) {
if (!(o->op_next->op_private & OPpDEREF)) {
null(o->op_next);
- o->op_private |= o->op_next->op_private & OPpLVAL_INTRO;
+ o->op_private |= o->op_next->op_private & (OPpLVAL_INTRO
+ | OPpOUR_INTRO);
o->op_next = o->op_next->op_next;
o->op_type = OP_GVSV;
o->op_ppaddr = PL_ppaddr[OP_GVSV];
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