From: Nicholas Clark 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)