Refactor the code used to check/execute BEGIN/UNITCHECK/CHECK/INIT/END

duplicated in newATTRSUB and newXS into a new static function
process_special_blocks()

p4raw-id: //depot/perl@30080

diff --git a/embed.fnc b/embed.fnc
index 0a369e3..2b3112d 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1211,6 +1211,8 @@ s |OP*    |newGIVWHENOP   |NULLOK OP* cond|NN OP *block \
                                |I32 enter_opcode|I32 leave_opcode \
                                |PADOFFSET entertarg
 s      |OP*    |ref_array_or_hash|NULLOK OP* cond
+s      |void   |process_special_blocks |NN const char *const fullname\
+                                       |NN GV *const gv|NN CV *const cv
 #endif
 #if defined(PL_OP_SLAB_ALLOC)
 Apa    |void*  |Slab_Alloc     |int m|size_t sz

diff --git a/embed.h b/embed.h
index a2f4230..aa6b1dd 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1194,6 +1194,7 @@
 #define looks_like_bool                S_looks_like_bool
 #define newGIVWHENOP           S_newGIVWHENOP
 #define ref_array_or_hash      S_ref_array_or_hash
+#define process_special_blocks S_process_special_blocks
 #endif
 #endif
 #if defined(PL_OP_SLAB_ALLOC)
@@ -3400,6 +3401,7 @@
 #define looks_like_bool(a)     S_looks_like_bool(aTHX_ a)
 #define newGIVWHENOP(a,b,c,d,e)        S_newGIVWHENOP(aTHX_ a,b,c,d,e)
 #define ref_array_or_hash(a)   S_ref_array_or_hash(aTHX_ a)
+#define process_special_blocks(a,b,c)  S_process_special_blocks(aTHX_ a,b,c)
 #endif
 #endif
 #if defined(PL_OP_SLAB_ALLOC)

diff --git a/op.c b/op.c
index 431c7a4..77d183b 100644 (file)
--- a/op.c
+++ b/op.c
@@ -5368,7 +5368,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     }
 
     if (name || aname) {
-       const char *s;
        const char * const tname = (name ? name : aname);
 
        if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
@@ -5396,15 +5395,25 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            }
        }
 
-       if ((s = strrchr(tname,':')))
-           s++;
-       else
-           s = tname;
+       if (!PL_error_count)
+           process_special_blocks(tname, gv, cv);
+    }
 
-       if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
-           goto done;
+  done:
+    PL_copline = NOLINE;
+    LEAVE_SCOPE(floor);
+    return cv;
+}
 
-       if (strEQ(s, "BEGIN") && !PL_error_count) {
+STATIC void
+S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv,
+                        CV *const cv)
+{
+    const char *const colon = strrchr(fullname,':');
+    const char *const name = colon ? colon + 1 : fullname;
+
+    if (*name == 'B') {
+       if (memEQ(name, "BEGIN", 5)) {
            const I32 oldscope = PL_scopestack_ix;
            ENTER;
            SAVECOPFILE(&PL_compiling);
@@ -5419,37 +5428,45 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            CopHINTS_set(&PL_compiling, PL_hints);
            LEAVE;
        }
-       else if (strEQ(s, "END") && !PL_error_count) {
-           DEBUG_x( dump_sub(gv) );
-           Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
-       else if (strEQ(s, "UNITCHECK") && !PL_error_count) {
-           /* It's never too late to run a unitcheck block */
-           DEBUG_x( dump_sub(gv) );
-           Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
-       else if (strEQ(s, "CHECK") && !PL_error_count) {
-           DEBUG_x( dump_sub(gv) );
-           if (PL_main_start && ckWARN(WARN_VOID))
-               Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
-           Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
-       else if (strEQ(s, "INIT") && !PL_error_count) {
-           DEBUG_x( dump_sub(gv) );
-           if (PL_main_start && ckWARN(WARN_VOID))
-               Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
-           Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
+       else
+           return;
+    } else {
+       if (*name == 'E') {
+           if strEQ(name, "END") {
+               DEBUG_x( dump_sub(gv) );
+               Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
+           } else
+               return;
+       } 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, (SV*)cv);
+           }
+           else
+               return;
+       } else if (*name == 'C') {
+           if (strEQ(name, "CHECK")) {
+               if (PL_main_start && ckWARN(WARN_VOID))
+                   Perl_warner(aTHX_ packWARN(WARN_VOID),
+                               "Too late to run CHECK block");
+               Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
+           }
+           else
+               return;
+       } else if (*name == 'I') {
+           if (strEQ(name, "INIT")) {
+               if (PL_main_start && ckWARN(WARN_VOID))
+                   Perl_warner(aTHX_ packWARN(WARN_VOID),
+                               "Too late to run INIT block");
+               Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
+           }
+           else
+               return;
+       } else
+           return;
+       DEBUG_x( dump_sub(gv) );
+       GvCV(gv) = 0;           /* cv has been hijacked */
     }
-
-  done:
-    PL_copline = NOLINE;
-    LEAVE_SCOPE(floor);
-    return cv;
 }
 
 /* XXX unsafe for threads if eval_owner isn't held */
@@ -5627,56 +5644,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename)
     CvISXSUB_on(cv);
     CvXSUB(cv) = subaddr;
 
-    if (name) {
-       const char *s = strrchr(name,':');
-       if (s)
-           s++;
-       else
-           s = name;
-
-       if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U')
-           goto done;
-
-       if (strEQ(s, "BEGIN")) {
-           const I32 oldscope = PL_scopestack_ix;
-           ENTER;
-           SAVECOPFILE(&PL_compiling);
-           SAVECOPLINE(&PL_compiling);
-
-           Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-           call_list(oldscope, PL_beginav);
-
-           PL_curcop = &PL_compiling;
-           CopHINTS_set(&PL_compiling, PL_hints);
-           LEAVE;
-       }
-       else if (strEQ(s, "END")) {
-           Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
-       else if (strEQ(s, "CHECK")) {
-           if (PL_main_start && ckWARN(WARN_VOID))
-               Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
-           Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
-       else if (strEQ(s, "UNITCHECK")) {
-           /* It's never too late to run a unitcheck block */
-           Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
-       else if (strEQ(s, "INIT")) {
-           if (PL_main_start && ckWARN(WARN_VOID))
-               Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
-           Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv);
-           GvCV(gv) = 0;               /* cv has been hijacked */
-       }
-    }
+    if (name)
+       process_special_blocks(name, gv, cv);
     else
        CvANON_on(cv);
 
-done:
     return cv;
 }
 

diff --git a/proto.h b/proto.h
index 0272b80..5eed24f 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3293,6 +3293,11 @@ STATIC OP*       S_newGIVWHENOP(pTHX_ OP* cond, OP *block, I32 enter_opcode, I32 leave
                        __attribute__nonnull__(pTHX_2);
 
 STATIC OP*     S_ref_array_or_hash(pTHX_ OP* cond);
+STATIC void    S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, CV *const cv)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2)
+                       __attribute__nonnull__(pTHX_3);
+
 #endif
 #if defined(PL_OP_SLAB_ALLOC)
 PERL_CALLCONV void*    Perl_Slab_Alloc(pTHX_ int m, size_t sz)