Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Make the try block have the same wantarray context as the sub its cal…

…led from
  • Loading branch information...
commit ef84ec374fe7b62761c0b0c49711230dabe4b8e0 1 parent b708682
@ashb authored
Showing with 96 additions and 10 deletions.
  1. +80 −2 TryCatch.xs
  2. +15 −3 lib/TryCatch.pm
  3. +1 −5 t/context.t
View
82 TryCatch.xs
@@ -19,11 +19,11 @@ dump_cxstack()
default:
continue;
case CXt_EVAL:
- printf("***\n* cx stack %d\n", (int)i);
+ printf("***\n* cx 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\n", (int)i);
+ printf("***\n* cx stack %d: WA: %d\n", (int)i, cx->blk_gimme);
sv_dump((SV*)cx->blk_sub.cv);
break;
}
@@ -31,6 +31,22 @@ dump_cxstack()
return i;
}
+// Return the (array)context of the first subroutine context up the Cx stack
+int get_sub_context()
+{
+ I32 i;
+ for (i = cxstack_ix; i >= 0; i--) {
+ register const PERL_CONTEXT * const cx = cxstack+i;
+ switch (CxTYPE(cx)) {
+ default:
+ continue;
+ case CXt_SUB:
+ return cx->blk_gimme;
+ }
+ }
+ return G_VOID;
+}
+
STATIC OP* unwind_return (pTHX_ OP *op, void *user_data) {
dSP;
@@ -72,6 +88,26 @@ STATIC OP* unwind_return (pTHX_ OP *op, void *user_data) {
return CALL_FPTR(PL_ppaddr[OP_ENTERSUB])(aTHXR);
}
+
+/* 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) {
+ Perl_croak(aTHX_ "Try Catch Internal Error: ENTERTRY op did not have VOID context (it was %d)", cx->blk_gimme);
+ }
+ cx->blk_gimme = get_sub_context();
+ return op;
+}
+
+STATIC OP* op_before_leavetry(pTHX_ OP *op, void *user_data) {
+ PERL_CONTEXT * cx = cxstack+cxstack_ix;
+ cx->blk_gimme = G_VOID;
+ 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) {
@@ -89,6 +125,41 @@ STATIC OP* check_return (pTHX_ OP *op, void *user_data) {
+// 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);
+ printf("enterytry op 0x%x try=%d at %s:%d\n",
+ op, is_try, cur_file, CopLINE(PL_curcop) );
+ }
+
+ 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;
+}
+
+// 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);
+ }
+ return op;
+}
+
+
void dualvar_id(SV* sv, UV id) {
char* file = CopFILE(&PL_compiling);
@@ -130,6 +201,13 @@ install_return_op_check()
XSRETURN(1);
void
+install_try_op_check()
+ CODE:
+ // TODO: Deal with perl 5.10.1+
+ ST(0) = install_op_check(OP_ENTEREVAL, check_entereval);
+ XSRETURN(1);
+
+void
uninstall_return_op_check(id)
SV* id
CODE:
View
18 lib/TryCatch.pm
@@ -21,6 +21,7 @@ our $VERSION = '1.001001';
# These are private state variables. Mess with them at your peril
our ($CHECK_OP_HOOK, $CHECK_OP_DEPTH) = (undef, 0);
+our $NEXT_EVAL_IS_TRY;
# Stack of state for tacking nested. Each value is number of catch blocks at
# the current level. We are nested if @STATE > 1
@@ -36,6 +37,9 @@ use Sub::Exporter -setup => {
installer => sub {
my ($args, $to_export) = @_;
my $pack = $args->{into};
+
+ TryCatch::XS::install_try_op_check();
+
foreach my $name (@$to_export) {
if (my $parser = __PACKAGE__->can("_parse_${name}")) {
Devel::Declare->setup_for(
@@ -189,9 +193,16 @@ sub block_postlude {
$ctx->_parse_catch;
} else {
- my $code = $ctx->state_have_catch_block()
- ? $ctx->injected_post_catch_code
- : $ctx->injected_no_catch_code;
+
+ # No (more) catch blocks, so write the postlude
+ my $code;
+ if ($ctx->state_have_catch_block) {
+ $code = $ctx->injected_post_catch_code;
+ }
+ else {
+ $code = $ctx->injected_no_catch_code;
+ $NEXT_EVAL_IS_TRY = 1;
+ }
substr($linestr, $offset, 0, $code);
@@ -233,6 +244,7 @@ sub _parse_catch {
@conditions = ('1') unless @conditions;
unless ($ctx->state_have_catch_block()) {
+ $NEXT_EVAL_IS_TRY = 1;
$code = $ctx->injected_after_try
. "if (";
}
View
6 t/context.t
@@ -12,13 +12,11 @@ sub fun {
$last_context = wantarray;
}
- catch ($e) {
+ catch ($e where { /^1/ }) {
$last_context = wantarray;
}
}
-{
-local $TODO = "Fix want-array contexts";
my @v;
$v[0] = fun();
is($last_context, '', "Scalar try context preserved");
@@ -28,9 +26,7 @@ is($last_context, 1, "Array try context preserved");
fun();
is($last_context, undef, "void try context preserved");
-}
-my @v;
$v[0] = fun(1);
is($last_context, '', "Scalar catch context preserved");
Please sign in to comment.
Something went wrong with that request. Please try again.