Permalink
Browse files

Use Scope::Upper's return ablility. Small bit of XS to detect wether …

…or not we returned
  • Loading branch information...
1 parent 281b306 commit 945796c7f6f40ce8b70cb4195fe4707b7b975ba4 @ashb ashb committed Jan 12, 2009
Showing with 147 additions and 12 deletions.
  1. +9 −0 .gitignore
  2. +19 −0 Makefile.PL
  3. +71 −0 TryCatch.xs
  4. +37 −8 lib/TryCatch.pm
  5. +11 −4 t/simple.t
View
@@ -0,0 +1,9 @@
+/TryCatch.*
+!TryCatch.xs
+Makefile.old
+Makefile
+.*.sw?
+pm_to_blib
+blib/
+inc/
+META.yml
View
@@ -0,0 +1,19 @@
+use strict;
+use warnings;
+
+require 5.008001;
+
+use inc::Module::Install 0.77;
+
+name 'TryCatch';
+all_from 'lib/TryCatch.pm';
+
+requires 'Parse::Method::Signatures';
+requires 'B::Hooks::EndOfScope' => 0.05;
+requires 'Devel::Declare';
+requires 'Moose';
+requires 'Scope::Upper' => 0.04;
+
+WriteAll;
+
+
View
@@ -0,0 +1,71 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#define MY_CXT_KEY "TryCatch::XS::_guts" XS_VERSION
+
+typedef struct {
+ int prev_op_is_return;
+ runops_proc_t old_runops;
+} my_cxt_t;
+
+START_MY_CXT
+
+static int
+my_runops(pTHX)
+{
+ OPCODE prev_opcode = OP_NULL;
+#ifdef PERL_IMPLICIT_CONTEXT
+ dMY_CXT;
+#else
+ dMY_CXT_INTERP(pTHX);
+#endif
+
+ while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX))) {
+ PERL_ASYNC_CHECK();
+ prev_opcode = PL_op->op_type;
+ }
+ MY_CXT.prev_op_is_return = prev_opcode==OP_RETURN;
+ TAINT_NOT;
+ return 0;
+}
+
+
+MODULE = TryCatch PACKAGE = TryCatch::XS
+
+
+BOOT:
+{
+ MY_CXT_INIT;
+ MY_CXT.prev_op_is_return = 0;
+}
+
+void
+_monitor_return(code, array_ctx)
+SV* code;
+SV* array_ctx; // Desired wantarray context;
+ PROTOTYPE: DISABLE
+ PREINIT:
+ dMY_CXT;
+ PPCODE:
+ int ret, ctx;
+
+ MY_CXT.old_runops = PL_runops;
+ MY_CXT.prev_op_is_return = 0;
+ PL_runops = &my_runops;
+
+ ctx = SvTRUE(array_ctx) ? G_ARRAY :
+ array_ctx != &PL_sv_undef ? G_SCALAR: G_VOID;
+
+ ret = call_sv(code, ctx);
+
+ SPAGAIN;
+ PL_runops = MY_CXT.old_runops;
+ XPUSHs(MY_CXT.prev_op_is_return ? &PL_sv_yes : &PL_sv_no);
+ XSRETURN(1+ret);
+
+void
+CLONE(...)
+ CODE:
+ MY_CXT_CLONE;
+
View
@@ -2,6 +2,15 @@ package TryCatch;
use strict;
use warnings;
+
+use base 'DynaLoader';
+
+our $VERSION = '1.000000';
+
+sub dl_load_flags { 0x01 }
+
+__PACKAGE__->bootstrap($VERSION);
+
use Sub::Exporter -setup => {
exports => [qw/try/],
groups => { default => [qw/try/] },
@@ -29,12 +38,16 @@ our $SPECIAL_VALUE = \"no return";
use Devel::Declare ();
use B::Hooks::EndOfScope;
-use B::Hooks::Parser;
use Devel::Declare::Context::Simple;
-use SlimSignature;
+#use Parse::Method::Signautres;
use Moose::Util::TypeConstraints;
+use Scope::Upper qw/unwind want_at/;
-sub try {}
+sub try ($) {
+ my @ret = TryCatch::XS::_monitor_return($_[0], want_at(1));
+ #print("_monitor_return returned @ret @{[scalar @ret]}\n");
+ unwind @ret, 1 if pop @ret;
+}
# This might be what catch should be
sub catch{
@@ -55,7 +68,7 @@ sub catch{
return $err if $cond->($err);
}
-# Replace try with an actual eval call;
+# Replace try {} with an try sub {};
sub _parse_try {
my $pack = shift;
@@ -65,8 +78,9 @@ sub _parse_try {
$ctx->inc_offset($len);
$ctx->skipspace;
my $ret = $ctx->inject_if_block(
- q# BEGIN { TryCatch::try_postlude() } { BEGIN {TryCatch::try_inner_postlude() } #,
- '; my $__t_c_ret = eval');
+ q# BEGIN { TryCatch::try_postlude() } #,
+ 'sub '
+ );
}
}
@@ -114,7 +128,7 @@ sub try_postlude_block {
} elsif ($toke eq 'finally') {
} else {
- my $str = '; return $__t_c_ret if !ref($__t_c_ret) || $__t_c_ret != $TryCatch::SPECIAL_VALUE;';
+ my $str = ';';# return $__t_c_ret if !ref($__t_c_ret) || $__t_c_ret != $TryCatch::SPECIAL_VALUE;';
substr( $linestr, $offset, 0 ) = $str;
$ctx->set_linestr($linestr);
@@ -155,7 +169,7 @@ sub process_catch {
print("process_catch: $first '$sub'\n");
if (substr($linestr, $ctx->offset, 1) eq '(') {
- my ($param, $left) = SlimSignature->param(
+ my ($param, $left) = ( # TODO: Parse::Method::Signatures->param
input => $linestr,
offset => $ctx->offset+1 );
@@ -206,4 +220,19 @@ sub process_catch {
substr($linestr, $ctx->offset) . "'\n");
$ctx->inject_if_block( 'BEGIN { TryCatch::catch_postlude() }');
}
+
1;
+
+__END__
+
+=head1 NAME
+
+TryCatch - first class try catch semantics for Perl, with no source filters.
+
+=head1 AUTHOR
+
+Ash Berlin <ash@cpan.org>
+
+=head1 LICENSE
+
+Licensed under the same terms as Perl itself.
View
@@ -5,17 +5,25 @@ use Test::More tests => 3;
BEGIN { use_ok "TryCatch" }
sub simple_return {
- #try {
- # 1+1;
- #}
try {
return "simple_return";
}
print("foo\n");
return "bar";
}
+sub simple_no_return {
+ try {
+ "simple_return"; # Not a return op
+ }
+
+ return "bar";
+}
+
+is(simple_return(), "simple_return");
+is(simple_no_return(), "bar");
+__END__
sub simple_catch {
try {
@@ -44,5 +52,4 @@ sub catch_2 {
return "Shouldn't get here either";
}
-is(simple_return(), "simple_return");
is(simple_catch(), "str_error: Foo\n");

0 comments on commit 945796c

Please sign in to comment.