diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | embedvar.h | 2 | ||||
| -rw-r--r-- | globvar.sym | 1 | ||||
| -rw-r--r-- | gv.c | 7 | ||||
| -rw-r--r-- | intrpvar.h | 3 | ||||
| -rw-r--r-- | mg.c | 8 | ||||
| -rw-r--r-- | perl.c | 31 | ||||
| -rw-r--r-- | perl.h | 26 | ||||
| -rw-r--r-- | sv.c | 1 | ||||
| -rw-r--r-- | t/op/magic_phase.t | 48 |
10 files changed, 119 insertions, 9 deletions
@@ -4687,6 +4687,7 @@ t/op/localref.t See if local ${deref} works t/op/local.t See if local works t/op/loopctl.t See if next/last/redo work t/op/lop.t See if logical operators work +t/op/magic_phase.t See if ${^GLOBAL_PHASE} works t/op/magic.t See if magic variables work t/op/method.t See if method calls work t/op/mkdir.t See if mkdir works diff --git a/embedvar.h b/embedvar.h index 36f75759be..ca316ef168 100644 --- a/embedvar.h +++ b/embedvar.h @@ -232,6 +232,7 @@ #define PL_perl_destruct_level (vTHX->Iperl_destruct_level) #define PL_perldb (vTHX->Iperldb) #define PL_perlio (vTHX->Iperlio) +#define PL_phase (vTHX->Iphase) #define PL_pidstatus (vTHX->Ipidstatus) #define PL_ppid (vTHX->Ippid) #define PL_preambleav (vTHX->Ipreambleav) @@ -562,6 +563,7 @@ #define PL_Iperl_destruct_level PL_perl_destruct_level #define PL_Iperldb PL_perldb #define PL_Iperlio PL_perlio +#define PL_Iphase PL_phase #define PL_Ipidstatus PL_pidstatus #define PL_Ippid PL_ppid #define PL_Ipreambleav PL_preambleav diff --git a/globvar.sym b/globvar.sym index fe1a7ee9ea..dc91e0c323 100644 --- a/globvar.sym +++ b/globvar.sym @@ -27,6 +27,7 @@ no_wrongref op_desc op_name opargs +phase_names ppaddr regkind reg_name @@ -1353,6 +1353,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (strEQ(name2, "NCODING")) goto magicalize; break; + case '\007': /* $^GLOBAL_PHASE */ + if (strEQ(name2, "LOBAL_PHASE")) + goto ro_magicalize; + break; case '\015': /* $^MATCH */ if (strEQ(name2, "ATCH")) goto magicalize; @@ -1362,7 +1366,8 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, break; case '\020': /* $^PREMATCH $^POSTMATCH */ if (strEQ(name2, "REMATCH") || strEQ(name2, "OSTMATCH")) - goto magicalize; + goto magicalize; + break; case '\024': /* ${^TAINT} */ if (strEQ(name2, "AINT")) goto ro_magicalize; diff --git a/intrpvar.h b/intrpvar.h index 1ab1495e8e..52e97119de 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -253,6 +253,9 @@ PERLVARI(Idirty, bool, FALSE) /* in the middle of tearing things PERLVAR(Iin_eval, U8) /* trap "fatal" errors? */ PERLVAR(Itainted, bool) /* using variables controlled by $< */ +/* current phase the interpreter is in */ +PERLVARI(Iphase, enum perl_phase, PERL_PHASE_CONSTRUCT) + /* This value may be set when embedding for full cleanup */ /* 0=none, 1=full, 2=full with checks */ /* mod_perl is special, and also assigns a meaning -1 */ @@ -877,6 +877,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) case '\006': /* ^F */ sv_setiv(sv, (IV)PL_maxsysfd); break; + case '\007': /* ^GLOBAL_PHASE */ + if (strEQ(remaining, "LOBAL_PHASE")) { + sv_setpvn(sv, PL_phase_names[PL_phase], + strlen(PL_phase_names[PL_phase])); + } + break; case '\010': /* ^H */ sv_setiv(sv, (IV)PL_hints); break; @@ -892,7 +898,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) Perl_emulate_cop_io(aTHX_ &PL_compiling, sv); } break; - case '\020': + case '\020': if (nextchar == '\0') { /* ^P */ sv_setiv(sv, (IV)PL_perldb); } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */ @@ -557,8 +557,10 @@ perl_destruct(pTHXx) JMPENV_PUSH(x); PERL_UNUSED_VAR(x); - if (PL_endav && !PL_minus_c) + if (PL_endav && !PL_minus_c) { + PL_phase = PERL_PHASE_END; call_list(PL_scopestack_ix, PL_endav); + } JMPENV_POP; } LEAVE; @@ -751,6 +753,7 @@ perl_destruct(pTHXx) * destruct_level > 0 */ SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; + PL_phase = PERL_PHASE_DESTRUCT; PL_dirty = TRUE; /* Tell PerlIO we are about to tear things apart in case @@ -1605,10 +1608,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) switch (ret) { case 0: parse_body(env,xsinit); - if (PL_unitcheckav) + if (PL_unitcheckav) { call_list(oldscope, PL_unitcheckav); - if (PL_checkav) + } + if (PL_checkav) { + PL_phase = PERL_PHASE_CHECK; call_list(oldscope, PL_checkav); + } ret = 0; break; case 1: @@ -1620,10 +1626,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_unitcheckav) + if (PL_unitcheckav) { call_list(oldscope, PL_unitcheckav); - if (PL_checkav) + } + if (PL_checkav) { + PL_phase = PERL_PHASE_CHECK; call_list(oldscope, PL_checkav); + } ret = STATUS_EXIT; break; case 3: @@ -1755,6 +1764,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) SV *linestr_sv = newSV_type(SVt_PVIV); bool add_read_e_script = FALSE; + PL_phase = PERL_PHASE_START; + SvGROW(linestr_sv, 80); sv_setpvs(linestr_sv,""); @@ -2245,8 +2256,10 @@ perl_run(pTHXx) FREETMPS; PL_curstash = PL_defstash; if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && - PL_endav && !PL_minus_c) + PL_endav && !PL_minus_c) { + PL_phase = PERL_PHASE_END; call_list(oldscope, PL_endav); + } #ifdef MYMALLOC if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); @@ -2295,8 +2308,10 @@ S_run_body(pTHX_ I32 oldscope) } if (PERLDB_SINGLE && PL_DBsingle) sv_setiv(PL_DBsingle, 1); - if (PL_initav) + if (PL_initav) { + PL_phase = PERL_PHASE_INIT; call_list(oldscope, PL_initav); + } #ifdef PERL_DEBUG_READONLY_OPS Perl_pending_Slabs_to_ro(aTHX); #endif @@ -2304,6 +2319,8 @@ S_run_body(pTHX_ I32 oldscope) /* do it */ + PL_phase = PERL_PHASE_RUN; + if (PL_restartop) { PL_restartjmpenv = NULL; PL_op = PL_restartop; @@ -4712,6 +4712,32 @@ EXTCONST char PL_bincompat_options[] = EXTCONST char PL_bincompat_options[]; #endif +/* The interpreter phases. If these ever change, PL_phase_names right below will + * need to be updated accordingly. */ +enum perl_phase { + PERL_PHASE_CONSTRUCT = 0, + PERL_PHASE_START = 1, + PERL_PHASE_CHECK = 2, + PERL_PHASE_INIT = 3, + PERL_PHASE_RUN = 4, + PERL_PHASE_END = 5, + PERL_PHASE_DESTRUCT = 6 +}; + +#ifdef DOINIT +EXTCONST char *const PL_phase_names[] = { + "CONSTRUCT", + "START", + "CHECK", + "INIT", + "RUN", + "END", + "DESTRUCT" +}; +#else +EXTCONST char *const PL_phase_names[]; +#endif + END_EXTERN_C /*****************************************************************************/ @@ -13124,6 +13124,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_in_eval = proto_perl->Iin_eval; PL_delaymagic = proto_perl->Idelaymagic; PL_dirty = proto_perl->Idirty; + PL_phase = proto_perl->Iphase; PL_localizing = proto_perl->Ilocalizing; PL_errors = sv_dup_inc(proto_perl->Ierrors, param); diff --git a/t/op/magic_phase.t b/t/op/magic_phase.t new file mode 100644 index 0000000000..07b4c19f7d --- /dev/null +++ b/t/op/magic_phase.t @@ -0,0 +1,48 @@ +#!./perl + +use strict; +use warnings; + +# Test ${^GLOBAL_PHASE} +# +# Test::More, test.pl, etc assert plans in END, which happens before global +# destruction, so we don't want to use those here. + +BEGIN { print "1..7\n" } + +sub ok ($$) { + print "not " if !$_[0]; + print "ok"; + print " - $_[1]" if defined $_[1]; + print "\n"; +} + +BEGIN { + ok ${^GLOBAL_PHASE} eq 'START', 'START'; +} + +CHECK { + ok ${^GLOBAL_PHASE} eq 'CHECK', 'CHECK'; +} + +INIT { + ok ${^GLOBAL_PHASE} eq 'INIT', 'INIT'; +} + +ok ${^GLOBAL_PHASE} eq 'RUN', 'RUN'; + +sub Moo::DESTROY { + ok ${^GLOBAL_PHASE} eq 'RUN', 'DESTROY is run-time too, usually'; +} + +my $tiger = bless {}, Moo::; + +sub Kooh::DESTROY { + ok ${^GLOBAL_PHASE} eq 'DESTRUCT', 'DESTRUCT'; +} + +our $affe = bless {}, Kooh::; + +END { + ok ${^GLOBAL_PHASE} eq 'END', 'END'; +} |