To cause actions on %^H to write out the serialisation records, it has
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> with a store
+ 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>
- saves the current C<PL_compiling.cop_hints> on the save stack, so that it
- will be correctly restored when any inner compiling scope is exited.
+ 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.
*/
#include "EXTERN.h"
/* "register" allocation */
PADOFFSET
-Perl_allocmy(pTHX_ char *name)
+Perl_allocmy(pTHX_ const char *const name)
{
dVAR;
PADOFFSET off;
{
/* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
- /* 1999-02-27 mjd@plover.com */
- char *p;
- p = strchr(name, '\0');
- /* The next block assumes the buffer is at least 205 chars
- long. At present, it's always at least 256 chars. */
- if (p - name > 200) {
-#ifdef HAS_STRLCPY
- strlcpy(name + 200, "...", 4);
-#else
- strcpy(name + 200, "...");
-#endif
- p = name + 199;
- }
- else {
- p[1] = '\0';
- }
- /* Move everything else down one character */
- for (; p-name > 2; p--)
- *p = *(p-1);
- name[2] = toCTRL(name[1]);
- name[1] = '^';
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"my\"",
+ name[0], toCTRL(name[1]), name + 2));
+ } else {
+ yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
/* check for duplicate declaration */
CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
PerlMemShared_free(cop->cop_warnings);
- if (! specialCopIO(cop->cop_io)) {
-#ifdef USE_ITHREADS
- NOOP;
-#else
- SvREFCNT_dec(cop->cop_io);
-#endif
- }
- Perl_refcounted_he_free(aTHX_ cop->cop_hints);
+ Perl_refcounted_he_free(aTHX_ cop->cop_hints_hash);
}
void
else
scalar(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
else
scalar(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SORT:
if (ckWARN(WARN_VOID))
else
list(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
else
list(kid);
}
- WITH_THR(PL_curcop = &PL_compiling);
+ PL_curcop = &PL_compiling;
break;
case OP_REQUIRE:
/* all requires must return a boolean value */
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
- SAVESPTR(PL_compiling.cop_io);
- if (! specialCopIO(PL_compiling.cop_io)) {
- PL_compiling.cop_io = newSVsv(PL_compiling.cop_io) ;
- SAVEFREESV(PL_compiling.cop_io) ;
- }
return retval;
}
int ret = 0;
I32 oldscope;
OP *old_next;
+ SV * const oldwarnhook = PL_warnhook;
+ SV * const olddiehook = PL_diehook;
dJMPENV;
if (PL_opargs[type] & OA_RETSCALAR)
oldscope = PL_scopestack_ix;
create_eval_scope(G_FAKINGEVAL);
+ PL_warnhook = PERL_WARNHOOK_FATAL;
+ PL_diehook = NULL;
JMPENV_PUSH(ret);
switch (ret) {
SvTEMP_off(sv);
}
break;
- case 2:
- /* my_exit() was called; propagate it */
- JMPENV_POP;
- JMPENV_JUMP(2);
- /* NOTREACHED */
case 3:
/* Something tried to die. Abandon constant folding. */
/* Pretend the error never happened. */
break;
default:
JMPENV_POP;
- /* Don't expect 1 (setjmp failed) */
+ /* Don't expect 1 (setjmp failed) or 2 (something called my_exit) */
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
+ /* XXX note that this croak may fail as we've already blown away
+ * the stack - eg any nested evals */
Perl_croak(aTHX_ "panic: fold_constants JMPENV_PUSH returned %d", ret);
}
-
JMPENV_POP;
+ PL_warnhook = oldwarnhook;
+ PL_diehook = olddiehook;
if (PL_scopestack_ix > oldscope)
delete_eval_scope();
* to store these values, evil chicanery is done with SvCUR().
*/
- if (!(left->op_private & OPpLVAL_INTRO)) {
+ {
OP *lastop = o;
PL_generation++;
for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) {
curop->op_type == OP_PADHV ||
curop->op_type == OP_PADANY)
{
+ if (curop->op_private & OPpPAD_STATE) {
+ if (left->op_private & OPpLVAL_INTRO) {
+ o->op_private |= OPpASSIGN_STATE;
+ /* hijacking PADSTALE for uninitialized state variables */
+ SvPADSTALE_on(PAD_SVl(curop->op_targ));
+ }
+ else if (ckWARN(WARN_MISC)) {
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "State variable %s will be reinitialized",
+ PAD_COMPNAME_PV(curop->op_targ));
+ }
+ }
if (PAD_COMPNAME_GEN(curop->op_targ)
== (STRLEN)PL_generation)
break;
PL_hints |= HINT_BLOCK_SCOPE;
}
cop->cop_seq = seq;
- CopARYBASE_set(cop, CopARYBASE_get(PL_curcop));
+ /* 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_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
- if (specialCopIO(PL_curcop->cop_io))
- cop->cop_io = PL_curcop->cop_io;
- else
- cop->cop_io = newSVsv(PL_curcop->cop_io) ;
- cop->cop_hints = PL_curcop->cop_hints;
- if (cop->cop_hints) {
+ cop->cop_hints_hash = PL_curcop->cop_hints_hash;
+ if (cop->cop_hints_hash) {
HINTS_REFCNT_LOCK;
- cop->cop_hints->refcounted_he_refcnt++;
+ cop->cop_hints_hash->refcounted_he_refcnt++;
HINTS_REFCNT_UNLOCK;
}
(op) == OP_EQ || (op) == OP_I_EQ || \
(op) == OP_NE || (op) == OP_I_NE || \
(op) == OP_NCMP || (op) == OP_I_NCMP)
- o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
+ o->op_private = (U8)(PL_hints & HINT_INTEGER);
if (!(o->op_flags & OPf_STACKED) /* Not an assignment */
&& (o->op_type == OP_BIT_OR
|| o->op_type == OP_BIT_AND
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
SV * const rsv = SvRV(kidsv);
- const int svtype = SvTYPE(rsv);
+ const svtype type = SvTYPE(rsv);
const char *badtype = NULL;
switch (o->op_type) {
case OP_RV2SV:
- if (svtype > SVt_PVMG)
+ if (type > SVt_PVMG)
badtype = "a SCALAR";
break;
case OP_RV2AV:
- if (svtype != SVt_PVAV)
+ if (type != SVt_PVAV)
badtype = "an ARRAY";
break;
case OP_RV2HV:
- if (svtype != SVt_PVHV)
+ if (type != SVt_PVHV)
badtype = "a HASH";
break;
case OP_RV2CV:
- if (svtype != SVt_PVCV)
+ if (type != SVt_PVCV)
badtype = "a CODE";
break;
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
{
+ OP *firstop;
OP *op = ((BINOP*)kid)->op_first;
name = NULL;
if (op) {
"[]" : "{}";
if (((op->op_type == OP_RV2AV) ||
(op->op_type == OP_RV2HV)) &&
- (op = ((UNOP*)op)->op_first) &&
- (op->op_type == OP_GV)) {
+ (firstop = ((UNOP*)op)->op_first) &&
+ (firstop->op_type == OP_GV)) {
/* packagevar $a[] or $h{} */
- GV * const gv = cGVOPx_gv(op);
+ GV * const gv = cGVOPx_gv(firstop);
if (gv)
tmpstr =
Perl_newSVpvf(aTHX_