#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
+#include "keywords.h"
/* #define PL_OP_SLAB_ALLOC */
STATIC void
S_no_bareword_allowed(pTHX_ OP *o)
{
- Perl_warn(aTHX_ "Bareword \"%s\" not allowed while \"strict subs\" in use",
- SvPV_nolen(cSVOPo->op_sv));
- ++PL_error_count;
+ qerror(Perl_mess(aTHX_
+ "Bareword \"%s\" not allowed while \"strict subs\" in use",
+ SvPV_nolen(cSVOPo->op_sv)));
}
/* "register" allocation */
SV *sv;
if (!(
+ PL_in_my == KEY_our ||
isALPHA(name[1]) ||
(PL_hints & HINT_UTF8 && (name[1] & 0xc0) == 0xc0) ||
- name[1] == '_' && (int)strlen(name) > 2))
+ name[1] == '_' && (int)strlen(name) > 2 ))
{
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
/* 1999-02-27 mjd@plover.com */
&& strEQ(name, SvPVX(sv)))
{
Perl_warner(aTHX_ WARN_UNSAFE,
- "\"my\" variable %s masks earlier declaration in same %s",
- name, (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
+ "\"%s\" variable %s masks earlier declaration in same %s",
+ (PL_in_my == KEY_our ? "our" : "my"),
+ name,
+ (SvIVX(sv) == PAD_MAX ? "scope" : "statement"));
break;
}
}
SvSTASH(sv) = (HV*)SvREFCNT_inc(PL_in_my_stash);
PL_sv_objcount++;
}
+ if (PL_in_my == KEY_our)
+ SvFLAGS(sv) |= SVpad_OUR;
av_store(PL_comppad_name, off, sv);
SvNVX(sv) = (NV)PAD_MAX;
SvIVX(sv) = 0; /* Not yet introduced--see newSTATEOP */
SvNVX(namesv) = (NV)PL_curcop->cop_seq;
SvIVX(namesv) = PAD_MAX; /* A ref, intro immediately */
SvFAKE_on(namesv); /* A ref, not a real var */
+ if (SvFLAGS(sv) & SVpad_OUR)/* An "our" variable */
+ SvFLAGS(namesv) |= SVpad_OUR;
if (SvOBJECT(sv)) { /* A typed var */
SvOBJECT_on(namesv);
(void)SvUPGRADE(namesv, SVt_PVMG);
seq > I_32(SvNVX(sv)))) &&
strEQ(SvPVX(sv), name))
{
- if (SvIVX(sv))
+ if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
return (PADOFFSET)off;
pendoff = off; /* this pending def. will override import */
}
default:
sv_magic(sv, 0, 0, name, 1);
}
- DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+ DEBUG_S(PerlIO_printf(Perl_error_log,
"find_threadsv: new SV %p for $%s%c\n",
sv, (*name < 32) ? "^" : "",
(*name < 32) ? toCTRL(*name) : *name));
if (kid->op_type == OP_METHOD_NAMED
|| kid->op_type == OP_METHOD)
{
- OP *new;
+ OP *newop;
if (kid->op_sibling || kid->op_next != kid) {
yyerror("panic: unexpected optree near method call");
break;
}
- NewOp(1101, new, 1, OP);
- new->op_type = OP_RV2CV;
- new->op_ppaddr = PL_ppaddr[OP_RV2CV];
- new->op_next = new;
- kid->op_sibling = new;
- new->op_private |= OPpLVAL_INTRO;
+ NewOp(1101, newop, 1, OP);
+ newop->op_type = OP_RV2CV;
+ newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
+ newop->op_next = newop;
+ kid->op_sibling = newop;
+ newop->op_private |= OPpLVAL_INTRO;
break;
}
my_kid(kid, attrs);
} else if (type == OP_UNDEF) {
return o;
+ } else if (type == OP_RV2SV || /* "our" declaration */
+ type == OP_RV2AV ||
+ type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+ return o;
} else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
o->op_type = OP_SCOPE;
o->op_ppaddr = PL_ppaddr[OP_SCOPE];
kid = ((LISTOP*)o)->op_first;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE){
- kid->op_type = OP_SETSTATE;
- kid->op_ppaddr = PL_ppaddr[OP_SETSTATE];
- }
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ null(kid);
}
else
o = newLISTOP(OP_SCOPE, 0, o, Nullop);
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
+ PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
}
if (k2 && k2->op_type == OP_READLINE
&& (k2->op_flags & OPf_STACKED)
&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
+ {
warnop = k2->op_type;
+ }
break;
case OP_SASSIGN:
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
+ || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
|| k1->op_type == OP_EACH)
- warnop = k1->op_type;
+ {
+ warnop = ((k1->op_type == OP_NULL)
+ ? k1->op_targ : k1->op_type);
+ }
break;
}
if (warnop) {
case OP_SASSIGN:
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
+ || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
|| k1->op_type == OP_EACH)
expr = newUNOP(OP_DEFINED, 0, expr);
break;
case OP_SASSIGN:
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
+ || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
|| k1->op_type == OP_EACH)
expr = newUNOP(OP_DEFINED, 0, expr);
break;
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
-#ifdef IV_IS_QUAD
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX,
- "Array @%s missing the @ in argument %" PERL_PRId64 " of %s()",
+ "Array @%s missing the @ in argument %"IVdf" of %s()",
name, (IV)numargs, PL_op_desc[type]);
-#else
- if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
- "Array @%s missing the @ in argument %ld of %s()",
- name, (long)numargs, PL_op_desc[type]);
-#endif
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
-#ifdef IV_IS_QUAD
if (ckWARN(WARN_SYNTAX))
Perl_warner(aTHX_ WARN_SYNTAX,
- "Hash %%%s missing the %% in argument %" PERL_PRId64 " of %s()",
+ "Hash %%%s missing the %% in argument %"IVdf" of %s()",
name, (IV)numargs, PL_op_desc[type]);
-#else
- if (ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
- "Hash %%%s missing the %% in argument %ld of %s()",
- name, (long)numargs, PL_op_desc[type]);
-#endif
op_free(kid);
kid = newop;
kid->op_sibling = sibl;
if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV)) && GvIMPORTED_CV(gv)))
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+#if 1 /*def PERL_INTERNAL_GLOB */
+ /* XXX this can be tightened up and made more failsafe. */
+ if (!gv) {
+ OP *modname = newSVOP(OP_CONST, 0, newSVpvn("File::Glob", 10));
+ modname->op_private |= OPpCONST_BARE;
+ ENTER;
+ utilize(1, start_subparse(FALSE, 0), Nullop, modname,
+ newSVOP(OP_CONST, 0, newSVpvn("globally", 8)));
+ gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+ LEAVE;
+ }
+#endif /* PERL_INTERNAL_GLOB */
+
if (gv && GvIMPORTED_CV(gv)) {
append_elem(OP_GLOB, o,
newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
&& !(kkid->op_private & OPpLVAL_INTRO))
{
/* Concat has problems if target is equal to right arg. */
- if (kid->op_type == OP_CONCAT
- && kLISTOP->op_first->op_sibling->op_type == OP_PADSV
- && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ)
- {
- return o;
+ if (kid->op_type == OP_CONCAT) {
+ if (kLISTOP->op_first->op_sibling->op_type == OP_PADSV
+ && kLISTOP->op_first->op_sibling->op_targ == kkid->op_targ)
+ return o;
}
- if (kid->op_type == OP_JOIN) {
- /* do_join has problems the arguments coincide with target.
+ else if (kid->op_type == OP_JOIN) {
+ /* do_join has problems if the arguments coincide with target.
In fact the second argument *can* safely coincide,
but ignore=pessimize this rare occasion. */
OP *arg = kLISTOP->op_first->op_sibling; /* Skip PUSHMARK */
arg = arg->op_sibling;
}
}
+ else if (kid->op_type == OP_QUOTEMETA) {
+ /* quotemeta has problems if the argument coincides with target. */
+ if (kLISTOP->op_first->op_type == OP_PADSV
+ && kLISTOP->op_first->op_targ == kkid->op_targ)
+ return o;
+ }
kid->op_targ = kkid->op_targ;
/* Now we do not need PADSV and SASSIGN. */
kid->op_sibling = o->op_sibling; /* NULL */
key = SvPV(*svp, keylen);
indsvp = hv_fetch(GvHV(*fields), key, keylen, FALSE);
if (!indsvp) {
- Perl_croak(aTHX_ "No such field \"%s\" in variable %s of type %s",
+ 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);
case OP_RV2AV:
case OP_RV2HV:
if (!(o->op_flags & OPf_WANT)
- || o->op_flags & OPf_WANT == OPf_WANT_LIST)
+ || (o->op_flags & OPf_WANT) == OPf_WANT_LIST)
+ {
last_composite = o;
+ }
o->op_seq = PL_op_seqmax++;
break;