perl
view release on metacpan or search on metacpan
SV * const sv = Perl_newSVpvf(aTHX_ "%s:%" LINE_Tf "-%" LINE_Tf,
CopFILE(PL_curcop),
(line_t)PL_subline,
CopLINE(PL_curcop));
(void)hv_store_ent(GvHV(PL_DBsub), tmpstr, sv, 0);
hv = GvHVn(db_postponed);
if (HvTOTALKEYS(hv) > 0 && hv_exists_ent(hv, tmpstr, 0)) {
CV * const pcv = GvCV(db_postponed);
if (pcv) {
PUSHMARK(PL_stack_sp);
#ifdef PERL_RC_STACK
assert(rpp_stack_is_rc());
#endif
rpp_xpush_1(tmpstr);
call_sv(MUTABLE_SV(pcv), G_DISCARD);
}
}
}
if (name) {
if (PL_parser && PL_parser->error_count)
clear_special_blocks(name, gv, cv);
else
evanescent =
process_special_blocks(floor, name, gv, cv);
}
}
assert(cv);
done:
assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
if (PL_parser)
PL_parser->copline = NOLINE;
LEAVE_SCOPE(floor);
assert(!cv || evanescent || SvREFCNT((SV*)cv) != 0);
if (!evanescent) {
#ifdef PERL_DEBUG_READONLY_OPS
if (slab)
Slab_to_ro(slab);
#endif
if (cv && name && block && CvOUTSIDE(cv) && !CvEVAL(CvOUTSIDE(cv)))
pad_add_weakref(cv);
}
return cv;
}
STATIC void
S_clear_special_blocks(pTHX_ const char *const fullname,
GV *const gv, CV *const cv) {
const char *colon;
const char *name;
PERL_ARGS_ASSERT_CLEAR_SPECIAL_BLOCKS;
colon = strrchr(fullname,':');
name = colon ? colon + 1 : fullname;
if ((*name == 'B' && strEQ(name, "BEGIN"))
|| (*name == 'E' && strEQ(name, "END"))
|| (*name == 'U' && strEQ(name, "UNITCHECK"))
|| (*name == 'C' && strEQ(name, "CHECK"))
|| (*name == 'I' && strEQ(name, "INIT"))) {
if (!isGV(gv)) {
(void)CvGV(cv);
assert(isGV(gv));
}
GvCV_set(gv, NULL);
SvREFCNT_dec_NN(MUTABLE_SV(cv));
}
}
/* Returns true if the sub has been freed. */
STATIC bool
S_process_special_blocks(pTHX_ I32 floor, const char *const fullname,
GV *const gv,
CV *const cv)
{
const char *const colon = strrchr(fullname,':');
const char *const name = colon ? colon + 1 : fullname;
PERL_ARGS_ASSERT_PROCESS_SPECIAL_BLOCKS;
if (*name == 'B') {
if (strEQ(name, "BEGIN")) {
/* can't goto a declaration, but a null statement is fine */
module_install_hack: ;
const I32 oldscope = PL_scopestack_ix;
SV *max_nest_sv = NULL;
IV max_nest_iv;
dSP;
(void)CvGV(cv);
if (floor) LEAVE_SCOPE(floor);
ENTER;
/* Make sure we don't recurse too deeply into BEGIN blocks,
* but let the user control it via the new control variable
*
* ${^MAX_NESTED_EVAL_BEGIN_BLOCKS}
*
* Note that this code (when max_nest_iv is 1) *looks* like
* it would block the following code:
*
* BEGIN { $n |= 1; BEGIN { $n |= 2; BEGIN { $n |= 4 } } }
*
* but it does *not*; this code will happily execute when
* the nest limit is 1. The reason is revealed in the
* execution order. If we could watch $n in this code, we
* would see the following order of modifications:
*
* $n |= 4;
* $n |= 2;
* $n |= 1;
*
* This is because nested BEGIN blocks execute in FILO
* order; this is because BEGIN blocks are defined to
* execute immediately once they are closed. So the
* innermost block is closed first, and it executes, which
* increments the eval_begin_nest_depth by 1, and then it
* finishes, which drops eval_begin_nest_depth back to its
* previous value. This happens in turn as each BEGIN is
max_nest_iv = SvIV(max_nest_sv);
if (max_nest_iv < 0) {
max_nest_iv = PERL_MAX_NESTED_EVAL_BEGIN_BLOCKS_DEFAULT;
sv_setiv(max_nest_sv, max_nest_iv);
}
/* (UV) below is just to silence a compiler warning, and should be
* effectively a no-op, as max_nest_iv will never be negative here.
*/
if (PL_eval_begin_nest_depth >= (UV)max_nest_iv) {
croak("Too many nested BEGIN blocks, maximum of %" IVdf " allowed",
max_nest_iv);
}
SAVEINT(PL_eval_begin_nest_depth);
PL_eval_begin_nest_depth++;
SAVEVPTR(PL_curcop);
if (PL_curcop == &PL_compiling) {
/* Avoid pushing the "global" &PL_compiling onto the
* context stack. For example, a stack trace inside
* nested use's would show all calls coming from whoever
* most recently updated PL_compiling.cop_file and
* cop_line. So instead, temporarily set PL_curcop to a
* private copy of &PL_compiling. PL_curcop will soon be
* set to point back to &PL_compiling anyway but only
* after the temp value has been pushed onto the context
* stack as blk_oldcop.
* This is slightly hacky, but necessary. Note also
* that in the brief window before PL_curcop is set back
* to PL_compiling, IN_PERL_COMPILETIME/IN_PERL_RUNTIME
* will give the wrong answer.
*/
PL_curcop = (COP*)newSTATEOP(PL_compiling.op_flags, NULL, NULL);
CopLINE_set(PL_curcop, CopLINE(&PL_compiling));
SAVEFREEOP(PL_curcop);
}
PUSHSTACKi(PERLSI_REQUIRE);
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
POPSTACK;
LEAVE;
return !PL_savebegin;
}
else
return FALSE;
} else {
if (*name == 'E') {
if (strEQ(name, "END")) {
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_unshift_one(aTHX_ &PL_endav, MUTABLE_SV(cv));
} else
return FALSE;
} else if (*name == 'U') {
if (strEQ(name, "UNITCHECK")) {
/* It's never too late to run a unitcheck block */
Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, MUTABLE_SV(cv));
}
else
return FALSE;
} else if (*name == 'C') {
if (strEQ(name, "CHECK")) {
if (PL_main_start)
/* diag_listed_as: Too late to run %s block */
ck_warner(packWARN(WARN_VOID),
"Too late to run CHECK block");
Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, MUTABLE_SV(cv));
}
else
return FALSE;
} else if (*name == 'I') {
if (strEQ(name, "INIT")) {
#ifdef MI_INIT_WORKAROUND_PACK
{
HV *hv = CvSTASH(cv);
STRLEN len = hv ? HvNAMELEN(hv) : 0;
char *pv = (len == sizeof(MI_INIT_WORKAROUND_PACK)-1)
? HvNAME_get(hv) : NULL;
if ( pv && strEQ(pv, MI_INIT_WORKAROUND_PACK) ) {
/* old versions of Module::Install::DSL contain code
* that creates an INIT in eval, which expects to run
* after an exit(0) in BEGIN. This unfortunately
* breaks a lot of code in the CPAN river. So we magically
* convert INIT blocks from Module::Install::DSL to
* be BEGIN blocks. Which works out, since the INIT
* blocks it creates are eval'ed and so are late.
*/
warn("Treating %s::INIT block as BEGIN block as workaround",
MI_INIT_WORKAROUND_PACK);
goto module_install_hack;
}
}
#endif
if (PL_main_start)
/* diag_listed_as: Too late to run %s block */
ck_warner(packWARN(WARN_VOID),
"Too late to run INIT block");
Perl_av_create_and_push(aTHX_ &PL_initav, MUTABLE_SV(cv));
}
else
return FALSE;
} else
return FALSE;
DEBUG_x( dump_sub(gv) );
(void)CvGV(cv);
GvCV_set(gv,0); /* cv has been hijacked */
return FALSE;
}
}
CV *
Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv)
{
return newCONSTSUB_flags(stash, name, name ? strlen(name) : 0, 0, sv);
( run in 1.343 second using v1.01-cache-2.11-cpan-5a3173703d6 )