Change 30727 by [EMAIL PROTECTED] on 2007/03/23 17:20:58
Integrate:
[ 30080]
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()
[ 30085]
You can't have special blocks if the subroutine has an "anonymous"
name for the debugger, so don't bother checking.
[ 30724]
Change 30080 was wrong to swap the BEGIN test to memEQ
Affected files ...
... //depot/maint-5.8/perl/embed.fnc#216 integrate
... //depot/maint-5.8/perl/embed.h#162 integrate
... //depot/maint-5.8/perl/op.c#212 integrate
... //depot/maint-5.8/perl/proto.h#208 integrate
Differences ...
==== //depot/maint-5.8/perl/embed.fnc#216 (text) ====
Index: perl/embed.fnc
--- perl/embed.fnc#215~30692~ 2007-03-22 10:55:41.000000000 -0700
+++ perl/embed.fnc 2007-03-23 10:20:58.000000000 -0700
@@ -1139,6 +1139,8 @@
#if defined(PERL_FLEXIBLE_EXCEPTIONS)
s |void* |vcall_runops |va_list args
#endif
+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
==== //depot/maint-5.8/perl/embed.h#162 (text+w) ====
Index: perl/embed.h
--- perl/embed.h#161~30692~ 2007-03-22 10:55:41.000000000 -0700
+++ perl/embed.h 2007-03-23 10:20:58.000000000 -0700
@@ -1137,6 +1137,9 @@
#define vcall_runops S_vcall_runops
#endif
#endif
+#ifdef PERL_CORE
+#define process_special_blocks S_process_special_blocks
+#endif
#endif
#if defined(PL_OP_SLAB_ALLOC)
#define Slab_Alloc Perl_Slab_Alloc
@@ -3239,6 +3242,9 @@
#define vcall_runops(a) S_vcall_runops(aTHX_ a)
#endif
#endif
+#ifdef PERL_CORE
+#define process_special_blocks(a,b,c) S_process_special_blocks(aTHX_ a,b,c)
+#endif
#endif
#if defined(PL_OP_SLAB_ALLOC)
#define Slab_Alloc(a,b) Perl_Slab_Alloc(aTHX_ a,b)
==== //depot/maint-5.8/perl/op.c#212 (text) ====
Index: perl/op.c
--- perl/op.c#211~30723~ 2007-03-23 08:27:22.000000000 -0700
+++ perl/op.c 2007-03-23 10:20:58.000000000 -0700
@@ -4639,9 +4639,6 @@
}
if (name || aname) {
- const char *s;
- const char * const tname = (name ? name : aname);
-
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
SV * const sv = newSV(0);
SV * const tmpstr = sv_newmortal();
@@ -4667,15 +4664,25 @@
}
}
- if ((s = strrchr(tname,':')))
- s++;
- else
- s = tname;
+ if (name && !PL_error_count)
+ process_special_blocks(name, gv, cv);
+ }
+
+ done:
+ PL_copline = NOLINE;
+ LEAVE_SCOPE(floor);
+ return cv;
+}
- if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
- goto done;
+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 (strEQ(s, "BEGIN") && !PL_error_count) {
+ if (*name == 'B') {
+ if (strEQ(name, "BEGIN")) {
const I32 oldscope = PL_scopestack_ix;
ENTER;
SAVECOPFILE(&PL_compiling);
@@ -4690,31 +4697,38 @@
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, "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 == '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 5005 threads if eval_owner isn't held */
@@ -4890,51 +4904,11 @@
an external constant string */
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')
- 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, "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;
}
==== //depot/maint-5.8/perl/proto.h#208 (text+w) ====
Index: perl/proto.h
--- perl/proto.h#207~30692~ 2007-03-22 10:55:41.000000000 -0700
+++ perl/proto.h 2007-03-23 10:20:58.000000000 -0700
@@ -1660,6 +1660,7 @@
#if defined(PERL_FLEXIBLE_EXCEPTIONS)
STATIC void* S_vcall_runops(pTHX_ va_list args);
#endif
+STATIC void S_process_special_blocks(pTHX_ const char *const fullname, GV
*const gv, CV *const cv);
#endif
#if defined(PL_OP_SLAB_ALLOC)
PERL_CALLCONV void* Perl_Slab_Alloc(pTHX_ int m, size_t sz)
End of Patch.
