From: Nicholas Clark <nick@ccl4.org>
Date: Tue, 30 Jan 2007 23:53:56 +0000 (+0000)
Subject: Refactor the code used to check/execute BEGIN/UNITCHECK/CHECK/INIT/END
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=33fb7a6edc5251e55242be2c5935f334082dd9b7;p=p5sagit%2Fp5-mst-13.2.git
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
--- 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
--- 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
--- 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
--- 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)