(PL_in_my == KEY_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
- : Nullhv
+ : NULL
),
0 /* not fake */
);
case OP_AND:
case OP_DOR:
case OP_COND_EXPR:
+ case OP_ENTERGIVEN:
+ case OP_ENTERWHEN:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
case OP_LEAVELOOP:
case OP_LINESEQ:
case OP_LIST:
+ case OP_LEAVEGIVEN:
+ case OP_LEAVEWHEN:
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
scalarvoid(kid);
break;
return o;
}
-/* Propagate lvalue ("modifiable") context to an op and it's children.
+/* Propagate lvalue ("modifiable") context to an op and its children.
* 'type' represents the context type, roughly based on the type of op that
* would do the modifying, although local() is represented by OP_NULL.
* It's responsible for detecting things that can't be modified, flag
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
- OP *rop = Nullop;
+ OP *rop;
/* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
* where the first kid is OP_PUSHMARK and the remaining ones
rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc(cSVOPo->op_sv));
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
+ rop = Nullop;
for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
if (o->op_type == OP_CONST)
rop = append_elem(OP_LIST, rop,
} else if (attrs) {
GV * const gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
apply_attrs(GvSTASH(gv),
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? (SV*)GvAV(gv) :
HV *stash;
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
/* check for C<my Dog $spot> when deciding package */
stash = PAD_COMPNAME_TYPE(o->op_targ);
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
- OP *rops = Nullop;
+ OP *rops;
int maybe_scalar = 0;
/* [perl #17376]: this appears to be premature, and results in code such as
#endif
if (attrs)
SAVEFREEOP(attrs);
+ rops = Nullop;
o = my_kid(o, attrs, &rops);
if (rops) {
if (maybe_scalar && o->op_type == OP_PADSV) {
o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
}
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
return o;
}
else
o = mod(o, OP_NULL); /* a bit kludgey */
PL_in_my = FALSE;
- PL_in_my_stash = Nullhv;
+ PL_in_my_stash = NULL;
return o;
}
/* XXX might want a ck_negate() for this */
cUNOPo->op_first->op_private &= ~OPpCONST_STRICT;
break;
- case OP_SPRINTF:
case OP_UCFIRST:
case OP_LCFIRST:
case OP_UC:
cLISTOPx(expr)->op_first->op_sibling == cLISTOPx(expr)->op_last)
{
/* convert single element list to element */
- OP* oe = expr;
+ OP* const oe = expr;
expr = cLISTOPx(oe)->op_first->op_sibling;
cLISTOPx(oe)->op_first->op_sibling = Nullop;
cLISTOPx(oe)->op_last = Nullop;
/* Result of assignment is always 1 (or we'd be dead already) */
return newSVOP(OP_CONST, 0, newSViv(1));
}
- /* optimise C<my @x = ()> to C<my @x>, and likewise for hashes */
- if ((left->op_type == OP_PADAV || left->op_type == OP_PADHV)
- && right->op_type == OP_STUB
- && (left->op_private & OPpLVAL_INTRO))
- {
- op_free(right);
- left->op_flags &= ~(OPf_REF|OPf_SPECIAL);
- return left;
- }
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
o->op_private = (U8)(0 | (flags >> 8));
iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */
sv->op_type = OP_RV2GV;
sv->op_ppaddr = PL_ppaddr[OP_RV2GV];
+ if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv)
+ iterpflags |= OPpITER_DEF;
}
else if (sv->op_type == OP_PADSV) { /* private variable */
iterpflags = sv->op_private & OPpLVAL_INTRO; /* for my $x () */
}
else
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
+ if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_"))
+ iterpflags |= OPpITER_DEF;
}
else {
const I32 offset = pad_findmy("$_");
else {
padoff = offset;
}
+ iterpflags |= OPpITER_DEF;
}
if (expr->op_type == OP_RV2AV || expr->op_type == OP_PADAV) {
expr = mod(force_list(scalar(ref(expr, OP_ITER))), OP_GREPSTART);
return o;
}
+/* if the condition is a literal array or hash
+ (or @{ ... } etc), make a reference to it.
+ */
+STATIC OP *
+S_ref_array_or_hash(pTHX_ OP *cond)
+{
+ if (cond
+ && (cond->op_type == OP_RV2AV
+ || cond->op_type == OP_PADAV
+ || cond->op_type == OP_RV2HV
+ || cond->op_type == OP_PADHV))
+
+ return newUNOP(OP_REFGEN,
+ 0, mod(cond, OP_REFGEN));
+
+ else
+ return cond;
+}
+
+/* These construct the optree fragments representing given()
+ and when() blocks.
+
+ entergiven and enterwhen are LOGOPs; the op_other pointer
+ points up to the associated leave op. We need this so we
+ can put it in the context and make break/continue work.
+ (Also, of course, pp_enterwhen will jump straight to
+ op_other if the match fails.)
+ */
+
+STATIC
+OP *
+S_newGIVWHENOP(pTHX_ OP *cond, OP *block,
+ I32 enter_opcode, I32 leave_opcode,
+ PADOFFSET entertarg)
+{
+ LOGOP *enterop;
+ OP *o;
+
+ NewOp(1101, enterop, 1, LOGOP);
+ enterop->op_type = enter_opcode;
+ enterop->op_ppaddr = PL_ppaddr[enter_opcode];
+ enterop->op_flags = (U8) OPf_KIDS;
+ enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
+ enterop->op_private = 0;
+
+ o = newUNOP(leave_opcode, 0, (OP *) enterop);
+
+ if (cond) {
+ enterop->op_first = scalar(cond);
+ cond->op_sibling = block;
+
+ o->op_next = LINKLIST(cond);
+ cond->op_next = (OP *) enterop;
+ }
+ else {
+ /* This is a default {} block */
+ enterop->op_first = block;
+ enterop->op_flags |= OPf_SPECIAL;
+
+ o->op_next = (OP *) enterop;
+ }
+
+ CHECKOP(enter_opcode, enterop); /* Currently does nothing, since
+ entergiven and enterwhen both
+ use ck_null() */
+
+ enterop->op_next = LINKLIST(block);
+ block->op_next = enterop->op_other = o;
+
+ return o;
+}
+
+/* Does this look like a boolean operation? For these purposes
+ a boolean operation is:
+ - a subroutine call [*]
+ - a logical connective
+ - a comparison operator
+ - a filetest operator, with the exception of -s -M -A -C
+ - defined(), exists() or eof()
+ - /$re/ or $foo =~ /$re/
+
+ [*] possibly surprising
+ */
+STATIC
+bool
+S_looks_like_bool(pTHX_ OP *o)
+{
+ switch(o->op_type) {
+ case OP_OR:
+ return looks_like_bool(cLOGOPo->op_first);
+
+ case OP_AND:
+ return (
+ looks_like_bool(cLOGOPo->op_first)
+ && looks_like_bool(cLOGOPo->op_first->op_sibling));
+
+ case OP_ENTERSUB:
+
+ case OP_NOT: case OP_XOR:
+ /* Note that OP_DOR is not here */
+
+ case OP_EQ: case OP_NE: case OP_LT:
+ case OP_GT: case OP_LE: case OP_GE:
+
+ case OP_I_EQ: case OP_I_NE: case OP_I_LT:
+ case OP_I_GT: case OP_I_LE: case OP_I_GE:
+
+ case OP_SEQ: case OP_SNE: case OP_SLT:
+ case OP_SGT: case OP_SLE: case OP_SGE:
+
+ case OP_SMARTMATCH:
+
+ case OP_FTRREAD: case OP_FTRWRITE: case OP_FTREXEC:
+ case OP_FTEREAD: case OP_FTEWRITE: case OP_FTEEXEC:
+ case OP_FTIS: case OP_FTEOWNED: case OP_FTROWNED:
+ case OP_FTZERO: case OP_FTSOCK: case OP_FTCHR:
+ case OP_FTBLK: case OP_FTFILE: case OP_FTDIR:
+ case OP_FTPIPE: case OP_FTLINK: case OP_FTSUID:
+ case OP_FTSGID: case OP_FTSVTX: case OP_FTTTY:
+ case OP_FTTEXT: case OP_FTBINARY:
+
+ case OP_DEFINED: case OP_EXISTS:
+ case OP_MATCH: case OP_EOF:
+
+ return TRUE;
+
+ case OP_CONST:
+ /* Detect comparisons that have been optimized away */
+ if (cSVOPo->op_sv == &PL_sv_yes
+ || cSVOPo->op_sv == &PL_sv_no)
+
+ return TRUE;
+
+ /* FALL THROUGH */
+ default:
+ return FALSE;
+ }
+}
+
+OP *
+Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
+{
+ assert( cond );
+ return newGIVWHENOP(
+ ref_array_or_hash(cond),
+ block,
+ OP_ENTERGIVEN, OP_LEAVEGIVEN,
+ defsv_off);
+}
+
+/* If cond is null, this is a default {} block */
+OP *
+Perl_newWHENOP(pTHX_ OP *cond, OP *block)
+{
+ bool cond_llb = (!cond || looks_like_bool(cond));
+ OP *cond_op;
+
+ if (cond_llb)
+ cond_op = cond;
+ else {
+ cond_op = newBINOP(OP_SMARTMATCH, OPf_SPECIAL,
+ newDEFSVOP(),
+ scalar(ref_array_or_hash(cond)));
+ }
+
+ return newGIVWHENOP(
+ cond_op,
+ append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
+ OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+}
+
/*
=for apidoc cv_undef
if (name || aname) {
const char *s;
- const char *tname = (name ? name : aname);
+ const char * const tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const sv = NEWSV(0,0);
goto done;
if (strEQ(s, "BEGIN") && !PL_error_count) {
- dSP;
const I32 oldscope = PL_scopestack_ix;
ENTER;
- PUSHSTACKi(PERLSI_REQUIRE);
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
PL_curcop = &PL_compiling;
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
- POPSTACK;
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
CvCONST_on(cv);
sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
+#ifdef USE_ITHREADS
if (stash)
CopSTASH_free(PL_curcop);
-
+#endif
LEAVE;
return cv;
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
register CV *cv;
- GV *gv;
- if (o)
- gv = gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM);
- else
- gv = gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
-
+ GV * const gv = o
+ ? gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM)
+ : gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
+
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- const OP *kid = cUNOPo->op_first;
+ const OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
!(kUNOP->op_first->op_flags & OPf_MOD))
o->op_flags |= OPf_STACKED;
o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
}
o->op_targ = (PADOFFSET)PL_hints;
+ if ((PL_hints & HINT_HH_FOR_EVAL) != 0 && GvHV(PL_hintgv))
+ {
+ /* Store a copy of %^H that pp_entereval can pick up */
+ OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
+ cUNOPo->op_first->op_sibling = hhop;
+ o->op_private |= OPpEVAL_HAS_HH;
+ }
return o;
}
Perl_ck_rvconst(pTHX_ register OP *o)
{
dVAR;
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ SVOP * const kid = (SVOP*)cUNOPo->op_first;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (kid->op_type == OP_CONST) {
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV *rsv = SvRV(kidsv);
+ SV * const rsv = SvRV(kidsv);
const int svtype = SvTYPE(rsv);
const char *badtype = Nullch;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newGVOP(OP_GV, 0,
+ OP * const newop = newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
{
- GV *gv = cGVOPx_gv(kUNOP->op_first);
+ GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
}
}
OP *
+Perl_ck_say(pTHX_ OP *o)
+{
+ o = ck_listiob(o);
+ o->op_type = OP_PRINT;
+ cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
+ = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
+ return o;
+}
+
+OP *
+Perl_ck_smartmatch(pTHX_ OP *o)
+{
+ if (0 == (o->op_flags & OPf_SPECIAL)) {
+ OP *first = cBINOPo->op_first;
+ OP *second = first->op_sibling;
+
+ /* Implicitly take a reference to an array or hash */
+ first->op_sibling = Nullop;
+ first = cBINOPo->op_first = ref_array_or_hash(first);
+ second = first->op_sibling = ref_array_or_hash(second);
+
+ /* Implicitly take a reference to a regular expression */
+ if (first->op_type == OP_MATCH) {
+ first->op_type = OP_QR;
+ first->op_ppaddr = PL_ppaddr[OP_QR];
+ }
+ if (second->op_type == OP_MATCH) {
+ second->op_type = OP_QR;
+ second->op_ppaddr = PL_ppaddr[OP_QR];
+ }
+ }
+
+ return o;
+}
+
+
+OP *
Perl_ck_sassign(pTHX_ OP *o)
{
OP *kid = cLISTOPo->op_first;
return kid;
}
}
- /* optimise C<my $x = undef> to C<my $x> */
- if (kid->op_type == OP_UNDEF) {
- OP * const kkid = kid->op_sibling;
- if (kkid && kkid->op_type == OP_PADSV
- && (kkid->op_private & OPpLVAL_INTRO))
- {
- cLISTOPo->op_first = NULL;
- kid->op_sibling = NULL;
- op_free(o);
- op_free(kid);
- return kkid;
- }
- }
return o;
}
OP *
Perl_ck_match(pTHX_ OP *o)
{
- if (o->op_type != OP_QR) {
+ if (o->op_type != OP_QR && PL_compcv) {
const I32 offset = pad_findmy("$_");
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
o->op_targ = offset;
{
OP *firstkid;
+ if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
+ {
+ HV *hinthv = GvHV(PL_hintgv);
+ if (hinthv) {
+ SV **svp = hv_fetch(hinthv, "sort", 4, 0);
+ if (svp) {
+ I32 sorthints = (I32)SvIV(*svp);
+ if ((sorthints & HINT_SORT_QUICKSORT) != 0)
+ o->op_private |= OPpSORT_QSORT;
+ if ((sorthints & HINT_SORT_STABLE) != 0)
+ o->op_private |= OPpSORT_STABLE;
+ }
+ }
+ }
+
if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
break;
case ']':
if (contextclass) {
+ /* XXX We shouldn't be modifying proto, so we can const proto */
char *p = proto;
const char s = *p;
contextclass = 0;
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
- OP* pop = (o->op_type == OP_PADAV) ?
+ OP* const pop = (o->op_type == OP_PADAV) ?
o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
projects / p5sagit/p5-mst-13.2.git / blobdiff