Permalink
Browse files

Finally fix things on perl 5.12

  • Loading branch information...
1 parent 3111d38 commit a6446c60248cc0925fa6c8de595bf32ea28beb5a @ashb committed Oct 13, 2010
Showing with 234 additions and 221 deletions.
  1. +6 −0 README
  2. +141 −101 TryCatch.xs
  3. +84 −120 lib/TryCatch.pm
  4. +3 −0 t/invalid.t
View
6 README
@@ -84,6 +84,8 @@ TODO
* Write some more documentation
+ * Split out the dependancy on Moose
+
SEE ALSO
MooseX::Types, Moose::Util::TypeConstraints, Parse::Method::Signatures.
@@ -96,6 +98,10 @@ THANKS
Vincent Pit for Scope::Upper that makes the return from block possible.
+ Zefram for providing support and XS guidance.
+
+ Xavier Bergade for the impetus to finally fix this module in 5.12.
+
LICENSE
Licensed under the same terms as Perl itself.
View
@@ -1,7 +1,9 @@
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
-#define NEED_sv_2pv_flags
+#define NEED_PL_parser_GLOBAL
+#define NEED_newRV_noinc_GLOBAL
+#define NEED_sv_2pv_flags_GLOBAL
#include "ppport.h"
#include "hook_op_check.h"
@@ -23,8 +25,8 @@ dump_cxstack()
default:
continue;
case CXt_EVAL:
- printf("***\n* cx stack %d: WA: %d\n", (int)i, cx->blk_gimme);
- sv_dump((SV*)cx->blk_eval.cv);
+ printf("***\n* eval stack %d: WA: %d\n", (int)i, cx->blk_gimme);
+ /* sv_dump((SV*)cx->blk_eval.cv); */
break;
case CXt_SUB:
printf("***\n* cx stack %d: WA: %d\n", (int)i, cx->blk_gimme);
@@ -35,7 +37,7 @@ dump_cxstack()
return i;
}
-// Return the (array)context of the first subroutine context up the Cx stack
+/* Return the (array)context of the first subroutine context up the Cx stack */
int get_sub_context()
{
I32 i;
@@ -52,7 +54,9 @@ int get_sub_context()
}
-STATIC OP* unwind_return (pTHX_ OP *op, void *user_data) {
+/* the implementation of 'return' op inside try blocks. */
+STATIC OP*
+try_return (pTHX_ OP *op, void *user_data) {
dSP;
SV* ctx;
CV *unwind;
@@ -64,22 +68,22 @@ STATIC OP* unwind_return (pTHX_ OP *op, void *user_data) {
if (ctx) {
XPUSHs( ctx );
PUTBACK;
- if (trycatch_debug & 1) {
+ if (trycatch_debug & 2) {
printf("have a $CTX of %d\n", SvIV(ctx));
}
} else {
PUSHMARK(SP);
PUTBACK;
call_pv("Scope::Upper::SUB", G_SCALAR);
- if (trycatch_debug & 1) {
+ if (trycatch_debug & 2) {
printf("No ctx, making it up\n");
}
SPAGAIN;
}
- if (trycatch_debug & 1) {
+ if (trycatch_debug & 2) {
printf("unwinding to %d\n", (int)SvIV(*sp));
}
@@ -101,152 +105,188 @@ STATIC OP* unwind_return (pTHX_ OP *op, void *user_data) {
return CALL_FPTR(PL_ppaddr[OP_ENTERSUB])(aTHX);
}
+/* The implementation of wantarray op/keyword inside try blocks. */
+STATIC OP*
+try_wantarray( pTHX_ OP *op, void *user_data ) {
+ PERL_UNUSED_VAR(op);
+ PERL_UNUSED_VAR(user_data);
-/* After the scope has been created, fix up the context */
-STATIC OP* op_after_entertry(pTHX_ OP *op, void *user_data) {
- PERL_CONTEXT * cx = cxstack+cxstack_ix;
-
- // Sanity check the gimme, since we'll reset it in leavetry
- if (cx->blk_gimme != G_VOID) {
- fprintf(stderr, "Try Catch Internal Error: ENTERTRY op did not have "
- "VOID context (it was %d)\n", cx->blk_gimme);
- abort();
+ dVAR;
+ dSP;
+ EXTEND(SP, 1);
+
+ /* We want the context from the closest subroutine, not from the closest
+ * block
+ */
+ switch ( get_sub_context() ) {
+ case G_ARRAY:
+ RETPUSHYES;
+ case G_SCALAR:
+ RETPUSHNO;
+ default:
+ RETPUSHUNDEF;
}
- cx->blk_gimme = get_sub_context();
- return op;
}
-STATIC OP* op_before_leavetry(pTHX_ OP *op, void *user_data) {
+
+/* After the scope has been created, fix up the context of the C<eval {}> block */
+STATIC OP*
+try_after_entertry(pTHX_ OP *op, void *user_data) {
PERL_CONTEXT * cx = cxstack+cxstack_ix;
- cx->blk_gimme = G_VOID;
+ cx->blk_gimme = get_sub_context();
return op;
}
-/* Hook the OP_RETURN iff we are in hte same file as originally compiling. */
-STATIC OP* check_return (pTHX_ OP *op, void *user_data) {
- const char* file = SvPV_nolen( (SV*)user_data );
- const char* cur_file = CopFILE(&PL_compiling);
- if (strcmp(file, cur_file)) {
- if (trycatch_debug & 4)
- Perl_warn(aTHX_ "Not hooking OP_return since its in '%s'", cur_file);
+STATIC OP*
+hook_if_correct_file( pTHX_ OP *op, void* user_data ) {
+ SV* eval_is_try;
+
+ const char* wanted_file = SvPV_nolen( (SV*)user_data );
+ const char* cur_file = CopFILE( &PL_compiling );
+ if ( strcmp(wanted_file, cur_file) ) {
+ if ( trycatch_debug & 4 )
+ Perl_warn( aTHX_ "Not hooking OP %s since its not in '%s'", PL_op_name[op->op_type], wanted_file );
return op;
}
- if (trycatch_debug & 1) {
- Perl_warn(aTHX_ "hooking OP_return");
+ if (trycatch_debug & 4) {
+ Perl_warn(aTHX_ "hooking OP %s", PL_op_name[op->op_type]);
}
- hook_op_ppaddr(op, unwind_return, NULL);
- return op;
-}
-
+ switch (op->op_type) {
+ case OP_WANTARRAY:
+ hook_op_ppaddr(op, try_wantarray, NULL);
+ break;
+ case OP_RETURN:
+ hook_op_ppaddr(op, try_return, NULL);
+ break;
-// If this eval scope should be marked by TryCatch, hook the ops
-STATIC OP* check_leavetry (pTHX_ OP *op, void *user_data) {
-
- SV* eval_is_try = get_sv("TryCatch::NEXT_EVAL_IS_TRY", 0);
-
- if (SvOK(eval_is_try) && SvTRUE(eval_is_try)) {
-
- OP* entertry = ((LISTOP*)op)->op_first;
-
- if (trycatch_debug & 2) {
- const char* cur_file = CopFILE(&PL_compiling);
- int is_try = SvIVx(eval_is_try);
- Perl_warn(aTHX_ "entertry op 0x%x try=%d", op, is_try);
- }
+#if (PERL_BCDVERSION < 0x5011000)
+ case OP_ENTEREVAL:
+ /* Do nothing if its still an entereval */
+ break;
+#endif
- SvIV_set(eval_is_try, 0);
- hook_op_ppaddr_around(entertry, NULL, op_after_entertry, NULL);
- hook_op_ppaddr_around(op, op_before_leavetry, NULL, NULL);
- }
- return op;
-}
+ case OP_LEAVETRY:
+ /* eval {} starts off as an OP_ENTEREVAL, and then the PL_check[OP_ENTEREVAL]
+ returns a newly created ENTERTRY (and LEAVETRY) ops without calling the
+ PL_check for these new ops into OP_ENTERTRY. How ever versions prior to perl
+ 5.10.1 didn't call the PL_check for these new ops */
+ hook_if_correct_file( aTHX_ ((LISTOP*)op)->op_first, user_data );
+ break;
+
+ case OP_ENTERTRY:
+ eval_is_try = get_sv("TryCatch::NEXT_EVAL_IS_TRY", 0);
+ if ( eval_is_try && SvOK( eval_is_try ) && SvTRUE( eval_is_try ) ) {
+ /* We've hooked a try block, so reset the flag */
+ SvIV_set( eval_is_try, 0 );
+ hook_op_ppaddr_around( op, NULL, try_after_entertry, NULL );
+ }
+ break;
-// eval {} starts off as an OP_ENTEREVAL, and then the PL_check[OP_ENTEREVAL]
-// returns a newly created ENTERTRY (and LEAVETRY) ops without calling the
-// PL_check for these new ops into OP_ENTERTRY. How ever versions prior to perl
-// 5.10.1 didn't call the PL_check for these new opes
-STATIC OP* check_entereval (pTHX_ OP *op, void *user_data) {
- if (op->op_type == OP_LEAVETRY) {
- return check_leavetry(aTHX_ op, user_data);
+ default:
+ fprintf(stderr, "Try Catch Internal Error: Unknown op %d: %s\n", op->op_type, PL_op_name[op->op_type]);
+ abort();
}
return op;
}
-void dualvar_id(SV* sv, UV id) {
+/* Hook all the *_check functions we need. Return an arrayref of:
+ *
+ * [ current_file_name, op_id, hook_id, op_id, hook_id, ... ]
+ */
+SV*
+xs_install_op_checks() {
+ SV *sv_curfile = newSV( 0 );
+ AV* av = newAV();
+ /* Get the filename we install check op hooks into. Need this so that we
+ don't hook ops if a require Other::Module happens in a try block. */
char* file = CopFILE(&PL_compiling);
STRLEN len = strlen(file);
- (void)SvUPGRADE(sv,SVt_PVNV);
+ (void)SvUPGRADE(sv_curfile,SVt_PVNV);
- sv_setpvn(sv,file,len);
-#ifdef SVf_IVisUV
- SvUV_set(sv, id);
- SvIOK_on(sv);
- SvIsUV_on(sv);
-#else
- SvIV_set(sv, id);
- SvIOK_on(sv);
-#endif
-}
+ sv_setpvn(sv_curfile,file,len);
+ av_push(av, sv_curfile);
-SV* install_op_check(int op_code, hook_op_ppaddr_cb_t hook_fn) {
- SV* ret;
- UV id;
+ #define do_hook(op) \
+ av_push(av, newSVuv( (op) ) ); \
+ av_push(av, newSVuv( hook_op_check( op, hook_if_correct_file, sv_curfile ) ) ); \
- ret = newSV(0);
+ /* This replace return with an unwird */
+ do_hook( OP_RETURN );
+ /* This fixes 'wantarray' keyword */
+ do_hook( OP_WANTARRAY );
+ /* And this gives the right context to C<return foo()> in a try block */
+ do_hook( OP_ENTERTRY );
+
+#if (PERL_BCDVERSION < 0x5011000)
+ /* Prior to 5.10.1(?) the ENTERTRY starts out as an ENTEREVAL and doesn't get
+ * PL_checked, so we need to hook ENTEREVAL (string eval) too and see if the
+ * type got changed. */
+ do_hook( OP_ENTEREVAL );
+#endif
- id = hook_op_check( op_code, hook_fn, ret );
- dualvar_id(ret, id);
+ #undef do_hook
- return ret;
+ /* Get an array ref form the array, return that. This keeps the sv_curfile alive */
+ return newRV_noinc( (SV*) av );
}
+
MODULE = TryCatch PACKAGE = TryCatch::XS
PROTOTYPES: DISABLE
void
-install_return_op_check()
- CODE:
- ST(0) = install_op_check(OP_RETURN, check_return);
- XSRETURN(1);
-
-void
-install_try_op_check()
+install_op_checks()
CODE:
- // TODO: Deal with perl 5.10.1+
- ST(0) = install_op_check(OP_ENTEREVAL, check_entereval);
+ ST(0) = xs_install_op_checks();
XSRETURN(1);
void
-uninstall_return_op_check(id)
-SV* id
+uninstall_op_checks( aref )
+SV* aref;
+ PREINIT:
+ AV* av;
+ SV *op, *id;
CODE:
-#ifdef SVf_IVisUV
- UV uiv = SvUV(id);
-#else
- UV uiv = SvIV(id);
-#endif
- hook_op_check_remove(OP_RETURN, uiv);
+ if ( !SvROK(aref) && SvTYPE(SvRV(aref)) != SVt_PVAV ) {
+ Perl_croak(aTHX_ "ArrayRef expected");
+ }
+ av = (AV*)(SvRV(aref));
+ /* throw away cur_file */
+ av_shift(av);
+ while (av_len(av) != -1) {
+ op = av_shift(av);
+ id = av_shift(av);
+ hook_op_check_remove( SvUV(op), SvUV(id) );
+ }
OUTPUT:
void dump_stack()
CODE:
dump_cxstack();
OUTPUT:
+void set_linestr_offset(int offset)
+ CODE:
+ char* linestr = SvPVX(PL_linestr);
+ PL_bufptr = linestr + offset;
+
BOOT:
{
char *debug = getenv ("TRYCATCH_DEBUG");
- int lvl = 0;
- if (debug && (lvl = atoi(debug)) && (lvl & (~1)) ) {
- trycatch_debug = lvl >> 1;
- printf("TryCatch XS debug enabled: %d\n", trycatch_debug);
+ /* Debug meanings:
+ 1 - line string changes (from the .pm)
+ 2 - Debug unwid contexts
+ 4 - debug op hooking
+ */
+ if (debug && (trycatch_debug = atoi(debug)) ) {
+ fprintf(stderr, "TryCatch XS debug enabled: %d\n", trycatch_debug);
}
}
Oops, something went wrong.

0 comments on commit a6446c6

Please sign in to comment.