Add ${^GLOBAL_PHASE}

This exposes the current top-level interpreter phase to perl space.

diff --git a/MANIFEST b/MANIFEST
index 14e11eb..78ca43c 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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/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
 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 36f7575..ca316ef 100644 (file)
--- 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_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_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_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
 #define PL_Ipidstatus          PL_pidstatus
 #define PL_Ippid               PL_ppid
 #define PL_Ipreambleav         PL_preambleav

diff --git a/globvar.sym b/globvar.sym
index fe1a7ee..dc91e0c 100644 (file)
--- a/globvar.sym
+++ b/globvar.sym
@@ -27,6 +27,7 @@ no_wrongref
 op_desc
 op_name
 opargs
 op_desc
 op_name
 opargs

+phase_names

 ppaddr
 regkind
 reg_name
 ppaddr
 regkind
 reg_name

diff --git a/gv.c b/gv.c
index 5a5a851..691dbba 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1353,6 +1353,10 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                if (strEQ(name2, "NCODING"))
                    goto magicalize;
                break;
                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;
             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"))
                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;
            case '\024':        /* ${^TAINT} */
                if (strEQ(name2, "AINT"))
                    goto ro_magicalize;

diff --git a/intrpvar.h b/intrpvar.h
index 1ab1495..52e9711 100644 (file)
--- 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 $< */
 
 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 */
 /* 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 */

diff --git a/mg.c b/mg.c
index 334eb80..01240a7 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -877,6 +877,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '\006':               /* ^F */
        sv_setiv(sv, (IV)PL_maxsysfd);
        break;
     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;
     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;
            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 */
        if (nextchar == '\0') {       /* ^P */
            sv_setiv(sv, (IV)PL_perldb);
        } else if (strEQ(remaining, "REMATCH")) { /* $^PREMATCH */

diff --git a/perl.c b/perl.c
index ed99612..8ed0960 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -557,8 +557,10 @@ perl_destruct(pTHXx)
 
         JMPENV_PUSH(x);
        PERL_UNUSED_VAR(x);
 
         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);
             call_list(PL_scopestack_ix, PL_endav);

+       }

         JMPENV_POP;
     }
     LEAVE;
         JMPENV_POP;
     }
     LEAVE;


@@ -751,6 +753,7 @@ perl_destruct(pTHXx)
      * destruct_level > 0 */
     SvREFCNT_dec(PL_main_cv);
     PL_main_cv = NULL;
      * 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
     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);
     switch (ret) {
     case 0:
        parse_body(env,xsinit);

-       if (PL_unitcheckav)
+       if (PL_unitcheckav) {

            call_list(oldscope, PL_unitcheckav);
            call_list(oldscope, PL_unitcheckav);

-       if (PL_checkav)
+       }
+       if (PL_checkav) {
+           PL_phase = PERL_PHASE_CHECK;

            call_list(oldscope, PL_checkav);
            call_list(oldscope, PL_checkav);

+       }

        ret = 0;
        break;
     case 1:
        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;
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;

-       if (PL_unitcheckav)
+       if (PL_unitcheckav) {

            call_list(oldscope, PL_unitcheckav);
            call_list(oldscope, PL_unitcheckav);

-       if (PL_checkav)
+       }
+       if (PL_checkav) {
+           PL_phase = PERL_PHASE_CHECK;

            call_list(oldscope, PL_checkav);
            call_list(oldscope, PL_checkav);

+       }

        ret = STATUS_EXIT;
        break;
     case 3:
        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;
 
     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,"");
 
     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) &&
        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);
            call_list(oldscope, PL_endav);

+       }

 #ifdef MYMALLOC
        if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
            dump_mstats("after execution:  ");
 #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 (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);
            call_list(oldscope, PL_initav);

+       }

 #ifdef PERL_DEBUG_READONLY_OPS
        Perl_pending_Slabs_to_ro(aTHX);
 #endif
 #ifdef PERL_DEBUG_READONLY_OPS
        Perl_pending_Slabs_to_ro(aTHX);
 #endif


@@ -2304,6 +2319,8 @@ S_run_body(pTHX_ I32 oldscope)
 
     /* do it */
 
 
     /* do it */
 

+    PL_phase = PERL_PHASE_RUN;
+

     if (PL_restartop) {
        PL_restartjmpenv = NULL;
        PL_op = PL_restartop;
     if (PL_restartop) {
        PL_restartjmpenv = NULL;
        PL_op = PL_restartop;

diff --git a/perl.h b/perl.h
index be0c8ff..fc7cf07 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -4712,6 +4712,32 @@ EXTCONST char PL_bincompat_options[] =
 EXTCONST char PL_bincompat_options[];
 #endif
 
 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
 
 /*****************************************************************************/
 END_EXTERN_C
 
 /*****************************************************************************/

diff --git a/sv.c b/sv.c
index d72d176..484b402 100644 (file)
--- a/sv.c
+++ b/sv.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_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);
     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 (file)
index 0000000..07b4c19
--- /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';
+}