This exposes the current top-level interpreter phase to perl space.
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
#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)
#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
op_desc
op_name
opargs
+phase_names
ppaddr
regkind
reg_name
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;
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;
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 */
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;
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 */
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;
* 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
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:
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:
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,"");
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: ");
}
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
/* do it */
+ PL_phase = PERL_PHASE_RUN;
+
if (PL_restartop) {
PL_restartjmpenv = NULL;
PL_op = PL_restartop;
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
/*****************************************************************************/
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);
--- /dev/null
+#!./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';
+}