magic type 'H'. This magic (itself) does nothing, but its presence causes
the values to gain magic type 'h', which has entries for set and clear.
C<Perl_magic_sethint> updates C<PL_compiling.cop_hints_hash> with a store
- record, with deletes written by C<Perl_magic_clearhint>. C<SAVE_HINTS>
+ record, with deletes written by C<Perl_magic_clearhint>. C<SAVEHINTS>
saves the current C<PL_compiling.cop_hints_hash> on the save stack, so that
it will be correctly restored when any inner compiling scope is exited.
*/
op_free(kid);
}
}
- if (type == OP_NULL)
- type = (OPCODE)o->op_targ;
#ifdef PERL_DEBUG_READONLY_OPS
Slab_to_rw(o);
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
- if (type == OP_NEXTSTATE || type == OP_DBSTATE) {
+ if (type == OP_NEXTSTATE || type == OP_DBSTATE
+ || (type == OP_NULL /* the COP might have been null'ed */
+ && ((OPCODE)o->op_targ == OP_NEXTSTATE
+ || (OPCODE)o->op_targ == OP_DBSTATE))) {
cop_free((COP*)o);
}
+ if (type == OP_NULL)
+ type = (OPCODE)o->op_targ;
+
op_clear(o);
if (o->op_latefree) {
o->op_latefreed = 1;
switch (o->op_type) {
case OP_NULL: /* Was holding old type, if any. */
if (PL_madskills && o->op_targ != OP_NULL) {
- o->op_type = o->op_targ;
+ o->op_type = (Optype)o->op_targ;
o->op_targ = 0;
goto retry;
}
break;
case OP_METHOD_NAMED:
case OP_CONST:
+ case OP_HINTSEVAL:
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
#ifdef USE_ITHREADS
{
PERL_ARGS_ASSERT_COP_FREE;
- CopLABEL_free(cop);
CopFILE_free(cop);
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
case OP_SORT:
if (ckWARN(WARN_VOID))
Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
+ break;
}
return o;
}
no_bareword_allowed(o);
else {
if (ckWARN(WARN_VOID)) {
- SV* msv = newSVpvf("a constant (%"SVf")", sv);
- useless = SvPV_nolen(msv);
+ if (SvOK(sv)) {
+ SV* msv = sv_2mortal(Perl_newSVpvf(aTHX_
+ "a constant (%"SVf")", sv));
+ useless = SvPV_nolen(msv);
+ }
+ else
+ useless = "a constant (undef)";
if (o->op_private & OPpCONST_ARYBASE)
useless = NULL;
/* don't warn on optimised away booleans, eg
case OP_OR:
case OP_AND:
+ kid = cLOGOPo->op_first;
+ if (kid->op_type == OP_NOT
+ && (kid->op_flags & OPf_KIDS)
+ && !PL_madskills) {
+ if (o->op_type == OP_AND) {
+ o->op_type = OP_OR;
+ o->op_ppaddr = PL_ppaddr[OP_OR];
+ } else {
+ o->op_type = OP_AND;
+ o->op_ppaddr = PL_ppaddr[OP_AND];
+ }
+ op_null(kid);
+ }
+
case OP_DOR:
case OP_COND_EXPR:
case OP_ENTERGIVEN:
OP *old_next;
SV * const oldwarnhook = PL_warnhook;
SV * const olddiehook = PL_diehook;
+ COP not_compiling;
dJMPENV;
PERL_ARGS_ASSERT_FOLD_CONSTANTS;
/* XXX what about the numeric ops? */
if (PL_hints & HINT_LOCALE)
goto nope;
+ break;
}
if (PL_parser && PL_parser->error_count)
oldscope = PL_scopestack_ix;
create_eval_scope(G_FAKINGEVAL);
+ /* Verify that we don't need to save it: */
+ assert(PL_curcop == &PL_compiling);
+ StructCopy(&PL_compiling, ¬_compiling, COP);
+ PL_curcop = ¬_compiling;
+ /* The above ensures that we run with all the correct hints of the
+ currently compiling COP, but that IN_PERL_RUNTIME is not true. */
+ assert(IN_PERL_RUNTIME);
PL_warnhook = PERL_WARNHOOK_FATAL;
PL_diehook = NULL;
JMPENV_PUSH(ret);
case 3:
/* Something tried to die. Abandon constant folding. */
/* Pretend the error never happened. */
- sv_setpvn(ERRSV,"",0);
+ CLEAR_ERRSV();
o->op_next = old_next;
break;
default:
JMPENV_POP;
PL_warnhook = oldwarnhook;
PL_diehook = olddiehook;
+ PL_curcop = &PL_compiling;
if (PL_scopestack_ix > oldscope)
delete_eval_scope();
if (PL_eval_start)
PL_eval_start = 0;
else {
- /* FIXME for MAD */
- op_free(o);
- o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
- o->op_private |= OPpCONST_ARYBASE;
+ if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
+ op_free(o);
+ o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
+ o->op_private |= OPpCONST_ARYBASE;
+ }
}
}
return o;
CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
- if (label) {
- CopLABEL_set(cop, label);
- PL_hints |= HINT_BLOCK_SCOPE;
- }
cop->cop_seq = seq;
/* CopARYBASE is now "virtual", in that it's stored as a flag bit in
CopHINTS and a possible value in cop_hints_hash, so no need to copy it.
cop->cop_hints_hash->refcounted_he_refcnt++;
HINTS_REFCNT_UNLOCK;
}
+ if (label) {
+ cop->cop_hints_hash
+ = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
+
+ PL_hints |= HINT_BLOCK_SCOPE;
+ /* It seems that we need to defer freeing this pointer, as other parts
+ of the grammar end up wanting to copy it after this op has been
+ created. */
+ SAVEFREEPV(label);
+ }
if (PL_parser && PL_parser->copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
}
}
+ if (flags & OPf_SPECIAL)
+ op_null((OP*)cop);
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
}
LOGOP *logop;
OP *o;
OP *first = *firstp;
- OP * const other = *otherp;
+ OP *other = *otherp;
+ int prepend_not = 0;
PERL_ARGS_ASSERT_NEW_LOGOP;
return newBINOP(type, flags, scalar(first), scalar(other));
scalarboolean(first);
- /* optimize "!a && b" to "a || b", and "!a || b" to "a && b" */
+ /* optimize AND and OR ops that have NOTs as children */
if (first->op_type == OP_NOT
- && (first->op_flags & OPf_SPECIAL)
&& (first->op_flags & OPf_KIDS)
+ && ((first->op_flags & OPf_SPECIAL) /* unless ($x) { } */
+ || (other->op_type == OP_NOT)) /* if (!$x && !$y) { } */
&& !PL_madskills) {
if (type == OP_AND || type == OP_OR) {
if (type == OP_AND)
type = OP_OR;
else
type = OP_AND;
- o = first;
- first = *firstp = cUNOPo->op_first;
- if (o->op_next)
- first->op_next = o->op_next;
- cUNOPo->op_first = NULL;
- op_free(o);
+ op_null(first);
+ if (other->op_type == OP_NOT) { /* !a AND|OR !b => !(a OR|AND b) */
+ op_null(other);
+ prepend_not = 1; /* prepend a NOT op later */
+ }
}
}
if (first->op_type == OP_CONST) {
CHECKOP(type,logop);
- o = newUNOP(OP_NULL, 0, (OP*)logop);
+ o = newUNOP(prepend_not ? OP_NOT : OP_NULL, 0, (OP*)logop);
other->op_next = o;
return o;
PERL_ARGS_ASSERT_NEWGIVWHENOP;
NewOp(1101, enterop, 1, LOGOP);
- enterop->op_type = enter_opcode;
+ enterop->op_type = (Optype)enter_opcode;
enterop->op_ppaddr = PL_ppaddr[enter_opcode];
enterop->op_flags = (U8) OPf_KIDS;
enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg);
}
o->op_targ = (PADOFFSET)PL_hints;
if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
- /* Store a copy of %^H that pp_entereval can pick up.
- OPf_SPECIAL flags the opcode as being for this purpose,
- so that it in turn will return a copy at every
- eval.*/
- OP *hhop = newSVOP(OP_CONST, OPf_SPECIAL,
+ /* Store a copy of %^H that pp_entereval can pick up. */
+ OP *hhop = newSVOP(OP_HINTSEVAL, 0,
(SV*)Perl_hv_copy_hints_hv(aTHX_ GvHV(PL_hintgv)));
cUNOPo->op_first->op_sibling = hhop;
o->op_private |= OPpEVAL_HAS_HH;
else if (kid->op_type == OP_AELEM)
o->op_flags |= OPf_SPECIAL;
else if (kid->op_type != OP_HELEM)
- Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element",
+ Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
OP_DESC(o));
op_null(kid);
}
#endif
return newop;
}
- if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o))
+ if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type))
o->op_private |= OPpFT_ACCESS;
if (PL_check[kidtype] == MEMBER_TO_FPTR(Perl_ck_ftst)
&& kidtype != OP_STAT && kidtype != OP_LSTAT)
}
OP *
-Perl_ck_lengthconst(pTHX_ OP *o)
-{
- PERL_ARGS_ASSERT_CK_LENGTHCONST;
-
- /* XXX length optimization goes here */
- return ck_fun(o);
-}
-
-OP *
Perl_ck_lfun(pTHX_ OP *o)
{
const OPCODE type = o->op_type;
if (table) {
SV **svp = hv_fetchs(table, "open_IN", FALSE);
if (svp && *svp) {
- const I32 mode = mode_from_discipline(*svp);
+ STRLEN len = 0;
+ const char *d = SvPV_const(*svp, len);
+ const I32 mode = mode_from_discipline(d, len);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_RAW;
else if (mode & O_TEXT)
svp = hv_fetchs(table, "open_OUT", FALSE);
if (svp && *svp) {
- const I32 mode = mode_from_discipline(*svp);
+ STRLEN len = 0;
+ const char *d = SvPV_const(*svp, len);
+ const I32 mode = mode_from_discipline(d, len);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_OUT_RAW;
else if (mode & O_TEXT)
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
#ifdef USE_ITHREADS
+ case OP_HINTSEVAL:
case OP_METHOD_NAMED:
/* Relocate sv to the pad for thread safety.
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOP->op_sv) {
const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
+ if (o->op_type != OP_METHOD_NAMED && SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
- else if (o->op_type == OP_CONST
+ else if (o->op_type != OP_METHOD_NAMED
&& cSVOPo->op_sv == &PL_sv_undef) {
/* PL_sv_undef is hack - it's unsafe to store it in the
AV that is the pad, because av_fetch treats values of
projects / p5sagit/p5-mst-13.2.git / blobdiff