+
+ - fix tests failing on 5.6.x due to differing DESTROY semantics
+ - excise superfluous local($@) call - 7% speedup
+ - fix (fsvo) broken URLs (RT#55659)
+ - proper exception on erroneous usage of bare catch/finally (RT#81070)
+ - proper exception on erroneous use of multiple catch{} blocks
+ - clarify exception occuring on unterminated try block (RT#75712)
+ - fix the prototypes shown in docs to match code (RT#79590; thanks, Pushtaev
+ Vadim)
+ - warn loudly on exceptions in finally() blocks
+
0.12
- doc fixes
- pass the error, if any, to finally blocks when called
0.06
- - in t/given_when.t use a plan instead of done_testing for more backwards
- compatibility
+ - in t/given_when.t use a plan instead of done_testing for more backwards
+ compatibility
0.05
- - Documentation fixes and clarifications
+ - Documentation fixes and clarifications
0.04
- - Restore list context propagation for catch blocks
- - Fix a bug where finally blocks weren't always invoked
+ - Restore list context propagation for catch blocks
+ - Fix a bug where finally blocks weren't always invoked
0.03
- - Support for 'finally' blocks (Andy Yates)
- - More documentation and tests (many people)
- - Sets $@ to the previous value at the beginning of the eval, to allow
- the capture of an error stack when calling die.
+ - Support for 'finally' blocks (Andy Yates)
+ - More documentation and tests (many people)
+ - Sets $@ to the previous value at the beginning of the eval, to allow
+ the capture of an error stack when calling die.
0.02
- - Doc fixes from chromatic
- - Various minor fixes from Adam Kennedy
- - Additional documentation and code clarifications
- - 5.005_04 compatibility
+ - Doc fixes from chromatic
+ - Various minor fixes from Adam Kennedy
+ - Additional documentation and code clarifications
+ - 5.005_04 compatibility
0.01
- - Initial release
+ - Initial release
\.gitignore$
MYMETA
+
+maint
use ExtUtils::MakeMaker;
-require 5.005_04;
+require 5.006;
WriteMakefile(
- NAME => 'Try::Tiny',
- VERSION_FROM => 'lib/Try/Tiny.pm',
- INSTALLDIRS => 'site',
- PL_FILES => { },
- PREREQ_PM => {
- 'Test::More' => 0,
- },
- META_MERGE => {
- resources => {
- homepage => 'https://github.com/doy/try-tiny.git',
- repository => 'git://github.com/doy/try-tiny.git',
- },
- },
+ NAME => 'Try::Tiny',
+ VERSION_FROM => 'lib/Try/Tiny.pm',
+ INSTALLDIRS => 'site',
+ PL_FILES => { },
+ PREREQ_PM => {
+ 'Test::More' => 0,
+ },
+ META_MERGE => {
+ dynamic_config => 0,
+ resources => {
+ homepage => 'https://github.com/doy/try-tiny.git',
+ repository => 'git://github.com/doy/try-tiny.git',
+ },
+ },
);
package Try::Tiny;
use strict;
-#use warnings;
+use warnings;
-use vars qw(@EXPORT @EXPORT_OK $VERSION @ISA);
+our $VERSION = "0.12";
+$VERSION = eval $VERSION if $VERSION =~ /_/;
-BEGIN {
- require Exporter;
- @ISA = qw(Exporter);
-}
-
-$VERSION = "0.12";
-
-$VERSION = eval $VERSION;
-
-@EXPORT = @EXPORT_OK = qw(try catch finally);
+use base 'Exporter';
+our @EXPORT = our @EXPORT_OK = qw(try catch finally);
+use Carp;
$Carp::Internal{+__PACKAGE__}++;
# Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
# context & not a scalar one
sub try (&;@) {
- my ( $try, @code_refs ) = @_;
-
- # we need to save this here, the eval block will be in scalar context due
- # to $failed
- my $wantarray = wantarray;
-
- my ( $catch, @finally );
-
- # find labeled blocks in the argument list.
- # catch and finally tag the blocks by blessing a scalar reference to them.
- foreach my $code_ref (@code_refs) {
- next unless $code_ref;
-
- my $ref = ref($code_ref);
-
- if ( $ref eq 'Try::Tiny::Catch' ) {
- $catch = ${$code_ref};
- } elsif ( $ref eq 'Try::Tiny::Finally' ) {
- push @finally, ${$code_ref};
- } else {
- use Carp;
- confess("Unknown code ref type given '${ref}'. Check your usage & try again");
- }
- }
-
- # save the value of $@ so we can set $@ back to it in the beginning of the eval
- my $prev_error = $@;
-
- my ( @ret, $error, $failed );
-
- # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
- # not perfect, but we could provide a list of additional errors for
- # $catch->();
-
- {
- # localize $@ to prevent clobbering of previous value by a successful
- # eval.
- local $@;
-
- # failed will be true if the eval dies, because 1 will not be returned
- # from the eval body
- $failed = not eval {
- $@ = $prev_error;
-
- # evaluate the try block in the correct context
- if ( $wantarray ) {
- @ret = $try->();
- } elsif ( defined $wantarray ) {
- $ret[0] = $try->();
- } else {
- $try->();
- };
-
- return 1; # properly set $fail to false
- };
-
- # copy $@ to $error; when we leave this scope, local $@ will revert $@
- # back to its previous value
- $error = $@;
- }
-
- # set up a scope guard to invoke the finally block at the end
- my @guards =
+ my ( $try, @code_refs ) = @_;
+
+ # we need to save this here, the eval block will be in scalar context due
+ # to $failed
+ my $wantarray = wantarray;
+
+ my ( $catch, @finally );
+
+ # find labeled blocks in the argument list.
+ # catch and finally tag the blocks by blessing a scalar reference to them.
+ foreach my $code_ref (@code_refs) {
+
+ if ( ref($code_ref) eq 'Try::Tiny::Catch' ) {
+ croak 'A try() may not be followed by multiple catch() blocks'
+ if $catch;
+ $catch = ${$code_ref};
+ } elsif ( ref($code_ref) eq 'Try::Tiny::Finally' ) {
+ push @finally, ${$code_ref};
+ } else {
+ croak(
+ 'try() encountered an unexpected argument ('
+ . ( defined $code_ref ? $code_ref : 'undef' )
+ . ') - perhaps a missing semi-colon before or'
+ );
+ }
+ }
+
+ # FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
+ # not perfect, but we could provide a list of additional errors for
+ # $catch->();
+
+ # save the value of $@ so we can set $@ back to it in the beginning of the eval
+ # and restore $@ after the eval finishes
+ my $prev_error = $@;
+
+ my ( @ret, $error );
+
+ # failed will be true if the eval dies, because 1 will not be returned
+ # from the eval body
+ my $failed = not eval {
+ $@ = $prev_error;
+
+ # evaluate the try block in the correct context
+ if ( $wantarray ) {
+ @ret = $try->();
+ } elsif ( defined $wantarray ) {
+ $ret[0] = $try->();
+ } else {
+ $try->();
+ };
+
+ return 1; # properly set $fail to false
+ };
+
+ # preserve the current error and reset the original value of $@
+ $error = $@;
+ $@ = $prev_error;
+
+ # set up a scope guard to invoke the finally block at the end
+ my @guards =
map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) }
@finally;
- # at this point $failed contains a true value if the eval died, even if some
- # destructor overwrote $@ as the eval was unwinding.
- if ( $failed ) {
- # if we got an error, invoke the catch block.
- if ( $catch ) {
- # This works like given($error), but is backwards compatible and
- # sets $_ in the dynamic scope for the body of C<$catch>
- for ($error) {
- return $catch->($error);
- }
-
- # in case when() was used without an explicit return, the C<for>
- # loop will be aborted and there's no useful return value
- }
-
- return;
- } else {
- # no failure, $@ is back to what it was, everything is fine
- return $wantarray ? @ret : $ret[0];
- }
+ # at this point $failed contains a true value if the eval died, even if some
+ # destructor overwrote $@ as the eval was unwinding.
+ if ( $failed ) {
+ # if we got an error, invoke the catch block.
+ if ( $catch ) {
+ # This works like given($error), but is backwards compatible and
+ # sets $_ in the dynamic scope for the body of C<$catch>
+ for ($error) {
+ return $catch->($error);
+ }
+
+ # in case when() was used without an explicit return, the C<for>
+ # loop will be aborted and there's no useful return value
+ }
+
+ return;
+ } else {
+ # no failure, $@ is back to what it was, everything is fine
+ return $wantarray ? @ret : $ret[0];
+ }
}
sub catch (&;@) {
- my ( $block, @rest ) = @_;
+ my ( $block, @rest ) = @_;
+
+ croak 'Useless bare catch()' unless defined wantarray;
- return (
- bless(\$block, 'Try::Tiny::Catch'),
- @rest,
- );
+ return (
+ bless(\$block, 'Try::Tiny::Catch'),
+ @rest,
+ );
}
sub finally (&;@) {
- my ( $block, @rest ) = @_;
+ my ( $block, @rest ) = @_;
- return (
- bless(\$block, 'Try::Tiny::Finally'),
- @rest,
- );
+ croak 'Useless bare finally()' unless defined wantarray;
+
+ return (
+ bless(\$block, 'Try::Tiny::Finally'),
+ @rest,
+ );
}
{
package # hide from PAUSE
Try::Tiny::ScopeGuard;
+ use constant UNSTABLE_DOLLARAT => ($] < '5.013002') ? 1 : 0;
+
sub _new {
shift;
bless [ @_ ];
}
sub DESTROY {
- my @guts = @{ shift() };
- my $code = shift @guts;
- $code->(@guts);
+ my ($code, @args) = @{ $_[0] };
+
+ local $@ if UNSTABLE_DOLLARAT;
+ eval {
+ $code->(@args);
+ 1;
+ } or do {
+ warn
+ "Execution of finally() block $code resulted in an exception, which "
+ . '*CAN NOT BE PROPAGATED* due to fundamental limitations of Perl. '
+ . 'Your program will continue as if this event never took place. '
+ . "Original exception text follows:\n\n"
+ . (defined $@ ? $@ : '$@ left undefined...')
+ . "\n"
+ ;
+ }
}
}
=head1 NAME
-Try::Tiny - minimal try/catch with proper localization of $@
+Try::Tiny - minimal try/catch with proper preservation of $@
=head1 SYNOPSIS
You can use Try::Tiny's C<try> and C<catch> to expect and handle exceptional
conditions, avoiding quirks in Perl and common mistakes:
- # handle errors with a catch handler
- try {
- die "foo";
- } catch {
- warn "caught error: $_"; # not $@
- };
+ # handle errors with a catch handler
+ try {
+ die "foo";
+ } catch {
+ warn "caught error: $_"; # not $@
+ };
You can also use it like a standalone C<eval> to catch and ignore any error
conditions. Obviously, this is an extreme measure not to be undertaken
lightly:
- # just silence errors
- try {
- die "foo";
- };
+ # just silence errors
+ try {
+ die "foo";
+ };
=head1 DESCRIPTION
context or the empty list in list context. The following examples all
assign C<"bar"> to C<$x>:
- my $x = try { die "foo" } catch { "bar" };
- my $x = try { die "foo" } || { "bar" };
- my $x = (try { die "foo" }) // { "bar" };
+ my $x = try { die "foo" } catch { "bar" };
+ my $x = try { die "foo" } || { "bar" };
+ my $x = (try { die "foo" }) // { "bar" };
- my $x = eval { die "foo" } || "bar";
+ my $x = eval { die "foo" } || "bar";
You can add C<finally> blocks, yielding the following:
- my $x;
- try { die 'foo' } finally { $x = 'bar' };
- try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };
+ my $x;
+ try { die 'foo' } finally { $x = 'bar' };
+ try { die 'foo' } catch { warn "Got a die: $_" } finally { $x = 'bar' };
C<finally> blocks are always executed making them suitable for cleanup code
which cannot be handled using local. You can add as many C<finally> blocks to a
Once all execution is finished then the C<finally> block, if given, will execute.
-=item catch (&;$)
+=item catch (&;@)
Intended to be used in the second argument position of C<try>.
C<Try::Tiny::Catch> which allows try to decode correctly what to do
with this code reference.
- catch { ... }
+ catch { ... }
Inside the C<catch> block the caught error is stored in C<$_>, while previous
value of C<$@> is still available for use. This value may or may not be
For code that captures C<$@> when throwing new errors (i.e.
L<Class::Throwable>), you'll need to do:
- local $@ = $_;
+ local $@ = $_;
-=item finally (&;$)
+=item finally (&;@)
try { ... }
catch { ... }
not do anything about handling possible errors coming from code located in these
blocks.
+Furthermore B<exceptions in C<finally> blocks are not trappable and are unable
+to influence the execution of your program>. This is due to limitation of
+C<DESTROY>-based scope guards, which C<finally> is implemented on top of. This
+may change in a future version of Try::Tiny.
+
In the same way C<catch()> blesses the code reference this subroutine does the same
except it bless them as C<Try::Tiny::Finally>.
also makes it impossible to capture the previous error before you die (for
instance when making exception objects with error stacks).
-For this reason C<try> will actually set C<$@> to its previous value (before
-the localization) in the beginning of the C<eval> block.
+For this reason C<try> will actually set C<$@> to its previous value (the one
+available before entering the C<try> block) in the beginning of the C<eval>
+block.
=head2 Localizing $@ silently masks errors
Inside an C<eval> block, C<die> behaves sort of like:
- sub die {
- $@ = $_[0];
- return_undef_from_eval();
- }
+ sub die {
+ $@ = $_[0];
+ return_undef_from_eval();
+ }
This means that if you were polite and localized C<$@> you can't die in that
scope, or your error will be discarded (printing "Something's wrong" instead).
The workaround is very ugly:
- my $error = do {
- local $@;
- eval { ... };
- $@;
- };
+ my $error = do {
+ local $@;
+ eval { ... };
+ $@;
+ };
- ...
- die $error;
+ ...
+ die $error;
=head2 $@ might not be a true value
This code is wrong:
- if ( $@ ) {
- ...
- }
+ if ( $@ ) {
+ ...
+ }
because due to the previous caveats it may have been unset.
The classic failure mode is:
- sub Object::DESTROY {
- eval { ... }
- }
+ sub Object::DESTROY {
+ eval { ... }
+ }
- eval {
- my $obj = Object->new;
+ eval {
+ my $obj = Object->new;
- die "foo";
- };
+ die "foo";
+ };
- if ( $@ ) {
+ if ( $@ ) {
- }
+ }
In this case since C<Object::DESTROY> is not localizing C<$@> but still uses
C<eval>, it will set C<$@> to C<"">.
can't save the value of C<$@> from code that doesn't localize, we can at least
be sure the C<eval> was aborted due to an error:
- my $failed = not eval {
- ...
+ my $failed = not eval {
+ ...
- return 1;
- };
+ return 1;
+ };
This is because an C<eval> that caught a C<die> will always return a false
value.
This is somewhat similar to Perl 6's C<CATCH> blocks. You can use it to
concisely match errors:
- try {
- require Foo;
- } catch {
- when (/^Can't locate .*?\.pm in \@INC/) { } # ignore
- default { die $_ }
- };
+ try {
+ require Foo;
+ } catch {
+ when (/^Can't locate .*?\.pm in \@INC/) { } # ignore
+ default { die $_ }
+ };
=head1 CAVEATS
arglist. In case you want to work with argument values directly via C<@_>
aliasing (i.e. allow C<$_[1] = "foo">), you need to pass C<@_> by reference:
- sub foo {
- my ( $self, @args ) = @_;
- try { $self->bar(@args) }
- }
+ sub foo {
+ my ( $self, @args ) = @_;
+ try { $self->bar(@args) }
+ }
or
- sub bar_in_place {
- my $self = shift;
- my $args = \@_;
- try { $_ = $self->bar($_) for @$args }
- }
+ sub bar_in_place {
+ my $self = shift;
+ my $args = \@_;
+ try { $_ = $self->bar($_) for @$args }
+ }
=item *
this is also how C<eval> works, but not how L<TryCatch> works):
sub parent_sub {
- try {
- die;
- }
- catch {
- return;
- };
+ try {
+ die;
+ }
+ catch {
+ return;
+ };
- say "this text WILL be displayed, even though an exception is thrown";
+ say "this text WILL be displayed, even though an exception is thrown";
}
Instead, you should capture the return value:
sub parent_sub {
- my $success = try {
- die;
- 1;
- }
- return unless $success;
+ my $success = try {
+ die;
+ 1;
+ }
+ return unless $success;
- say "This text WILL NEVER appear!";
+ say "This text WILL NEVER appear!";
}
Note that if you have a C<catch> block, it must return C<undef> for this to work,
of the expression for truth on success, be sure to return a false value from
the C<catch> block:
- my $obj = try {
- MightFail->new;
- } catch {
- ...
+ my $obj = try {
+ MightFail->new;
+ } catch {
+ ...
- return; # avoid returning a true value;
- };
+ return; # avoid returning a true value;
+ };
- return unless $obj;
+ return unless $obj;
=item *
For example Perl 5.10's C<given> form uses a lexical C<$_>, creating some
confusing behavior:
- given ($foo) {
- when (...) {
- try {
- ...
- } catch {
- warn $_; # will print $foo, not the error
- warn $_[0]; # instead, get the error like this
- }
- }
- }
+ given ($foo) {
+ when (...) {
+ try {
+ ...
+ } catch {
+ warn $_; # will print $foo, not the error
+ warn $_[0]; # instead, get the error like this
+ }
+ }
+ }
+
+Note that this behavior was changed once again in L<Perl5 version 18
+|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>.
+However, since the entirety of lexical C<$_> is now L<considired experimental
+|https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it
+is unclear whether the new version 18 behavior is final.
=back
I gave a lightning talk about this module, you can see the slides (Firefox
only):
-L<http://nothingmuch.woobling.org/talks/takahashi.xul?data=yapc_asia_2009/try_tiny.txt>
+L<http://web.archive.org/web/20100628040134/http://nothingmuch.woobling.org/talks/takahashi.xul>
Or read the source:
-L<http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>
+L<http://web.archive.org/web/20100305133605/http://nothingmuch.woobling.org/talks/yapc_asia_2009/try_tiny.yml>
=head1 VERSION CONTROL
=head1 COPYRIGHT
- Copyright (c) 2009 Yuval Kogman. All rights reserved.
- This program is free software; you can redistribute
- it and/or modify it under the terms of the MIT license.
+ Copyright (c) 2009 Yuval Kogman. All rights reserved.
+ This program is free software; you can redistribute
+ it and/or modify it under the terms of the MIT license.
=cut
--- /dev/null
+#!/usr/bin/env perl
+
+use warnings;
+use strict;
+
+use Benchmark::Dumb ':all';
+use Try::Tiny;
+
+my $max = 10_000;
+
+cmpthese('0.003', {
+ eval => sub { do { local $@; eval { die 'foo' } } for (1..$max) },
+ try => sub { do { try { die 'foo' } } for (1..$max) },
+});
#!/usr/bin/perl
use strict;
-#use warnings;
+use warnings;
use Test::More tests => 26;
BEGIN { use_ok 'Try::Tiny' };
sub _eval {
- local $@;
- local $Test::Builder::Level = $Test::Builder::Level + 2;
- return ( scalar(eval { $_[0]->(); 1 }), $@ );
+ local $@;
+ local $Test::Builder::Level = $Test::Builder::Level + 2;
+ return ( scalar(eval { $_[0]->(); 1 }), $@ );
}
sub lives_ok (&$) {
- my ( $code, $desc ) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ( $code, $desc ) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
- my ( $ok, $error ) = _eval($code);
+ my ( $ok, $error ) = _eval($code);
- ok($ok, $desc );
+ ok($ok, $desc );
- diag "error: $@" unless $ok;
+ diag "error: $@" unless $ok;
}
sub throws_ok (&$$) {
- my ( $code, $regex, $desc ) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
+ my ( $code, $regex, $desc ) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
- my ( $ok, $error ) = _eval($code);
+ my ( $ok, $error ) = _eval($code);
- if ( $ok ) {
- fail($desc);
- } else {
- like($error || '', $regex, $desc );
- }
+ if ( $ok ) {
+ fail($desc);
+ } else {
+ like($error || '', $regex, $desc );
+ }
}
my $prev;
lives_ok {
- try {
- die "foo";
- };
+ try {
+ die "foo";
+ };
} "basic try";
throws_ok {
- try {
- die "foo";
- } catch { die $_ };
+ try {
+ die "foo";
+ } catch { die $_ };
} qr/foo/, "rethrow";
{
- local $@ = "magic";
- is( try { 42 }, 42, "try block evaluated" );
- is( $@, "magic", '$@ untouched' );
+ local $@ = "magic";
+ is( try { 42 }, 42, "try block evaluated" );
+ is( $@, "magic", '$@ untouched' );
}
{
- local $@ = "magic";
- is( try { die "foo" }, undef, "try block died" );
- is( $@, "magic", '$@ untouched' );
+ local $@ = "magic";
+ is( try { die "foo" }, undef, "try block died" );
+ is( $@, "magic", '$@ untouched' );
}
{
- local $@ = "magic";
- like( (try { die "foo" } catch { $_ }), qr/foo/, "catch block evaluated" );
- is( $@, "magic", '$@ untouched' );
+ local $@ = "magic";
+ like( (try { die "foo" } catch { $_ }), qr/foo/, "catch block evaluated" );
+ is( $@, "magic", '$@ untouched' );
}
is( scalar(try { "foo", "bar", "gorch" }), "gorch", "scalar context try" );
{
- my ($sub) = catch { my $a = $_; };
- is(ref($sub), 'Try::Tiny::Catch', 'Checking catch subroutine scalar reference is correctly blessed');
+ my ($sub) = catch { my $a = $_; };
+ is(ref($sub), 'Try::Tiny::Catch', 'Checking catch subroutine scalar reference is correctly blessed');
}
{
- my ($sub) = finally { my $a = $_; };
- is(ref($sub), 'Try::Tiny::Finally', 'Checking finally subroutine scalar reference is correctly blessed');
+ my ($sub) = finally { my $a = $_; };
+ is(ref($sub), 'Try::Tiny::Finally', 'Checking finally subroutine scalar reference is correctly blessed');
}
lives_ok {
- try {
- die "foo";
- } catch {
- my $err = shift;
-
- try {
- like $err, qr/foo/;
- } catch {
- fail("shouldn't happen");
- };
-
- pass "got here";
- }
+ try {
+ die "foo";
+ } catch {
+ my $err = shift;
+
+ try {
+ like $err, qr/foo/;
+ } catch {
+ fail("shouldn't happen");
+ };
+
+ pass "got here";
+ }
} "try in try catch block";
throws_ok {
- try {
- die "foo";
- } catch {
- my $err = shift;
+ try {
+ die "foo";
+ } catch {
+ my $err = shift;
- try { } catch { };
+ try { } catch { };
- die "rethrowing $err";
- }
+ die "rethrowing $err";
+ }
} qr/rethrowing foo/, "rethrow with try in catch block";
sub Evil::DESTROY {
- eval { "oh noes" };
+ eval { "oh noes" };
}
sub Evil::new { bless { }, $_[0] }
{
- local $@ = "magic";
- local $_ = "other magic";
-
- try {
- my $object = Evil->new;
- die "foo";
- } catch {
- pass("catch invoked");
- local $TODO = "i don't think we can ever make this work sanely, maybe with SIG{__DIE__}" if $] < 5.014;
- like($_, qr/foo/);
- };
-
- is( $@, "magic", '$@ untouched' );
- is( $_, "other magic", '$_ untouched' );
+ local $@ = "magic";
+ local $_ = "other magic";
+
+ try {
+ my $object = Evil->new;
+ die "foo";
+ } catch {
+ pass("catch invoked");
+ local $TODO = "i don't think we can ever make this work sanely, maybe with SIG{__DIE__}" if $] < 5.014;
+ like($_, qr/foo/);
+ };
+
+ is( $@, "magic", '$@ untouched' );
+ is( $_, "other magic", '$_ untouched' );
}
{
- my ( $caught, $prev );
+ my ( $caught, $prev );
- {
- local $@;
+ {
+ local $@;
- eval { die "bar\n" };
+ eval { die "bar\n" };
- is( $@, "bar\n", 'previous value of $@' );
+ is( $@, "bar\n", 'previous value of $@' );
- try {
- die {
- prev => $@,
- }
- } catch {
- $caught = $_;
- $prev = $@;
- }
- }
+ try {
+ die {
+ prev => $@,
+ }
+ } catch {
+ $caught = $_;
+ $prev = $@;
+ }
+ }
- is_deeply( $caught, { prev => "bar\n" }, 'previous value of $@ available for capture' );
- is( $prev, "bar\n", 'previous value of $@ also available in catch block' );
+ is_deeply( $caught, { prev => "bar\n" }, 'previous value of $@ available for capture' );
+ is( $prev, "bar\n", 'previous value of $@ also available in catch block' );
}
return 'catch';
}
finally {
- is (wantarray, undef, "Proper VOID context in finally{} 1");
+ SKIP: {
+ skip "DESTROY() not called in void context on perl $]", 1
+ if $] < '5.008';
+ is (wantarray, undef, "Proper VOID context in finally{} 1");
+ }
return 'finally';
}
finally {
- is (wantarray, undef, "Proper VOID context in finally{} 2");
+ SKIP: {
+ skip "DESTROY() not called in void context on perl $]", 1
+ if $] < '5.008';
+ is (wantarray, undef, "Proper VOID context in finally{} 2");
+ }
return 'finally';
};
}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 6;
+use Try::Tiny;
+
+sub _eval {
+ local $@;
+ local $Test::Builder::Level = $Test::Builder::Level + 2;
+ return ( scalar(eval { $_[0]->(); 1 }), $@ );
+}
+
+sub throws_ok (&$$) {
+ my ( $code, $regex, $desc ) = @_;
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ my ( $ok, $error ) = _eval($code);
+
+ if ( $ok ) {
+ fail($desc);
+ } else {
+ like($error || '', $regex, $desc );
+ }
+}
+
+throws_ok {
+ try { 1 }; catch { 2 };
+} qr/\QUseless bare catch()/, 'Bare catch() detected';
+
+throws_ok {
+ try { 1 }; finally { 2 };
+} qr/\QUseless bare finally()/, 'Bare finally() detected';
+
+throws_ok {
+ try { 1 }; catch { 2 } finally { 2 };
+} qr/\QUseless bare catch()/, 'Bare catch()/finally() detected';
+
+throws_ok {
+ try { 1 }; finally { 2 } catch { 2 };
+} qr/\QUseless bare finally()/, 'Bare finally()/catch() detected';
+
+
+throws_ok {
+ try { 1 } catch { 2 } catch { 3 } finally { 4 } finally { 5 }
+} qr/\QA try() may not be followed by multiple catch() blocks/, 'Multi-catch detected';
+
+
+throws_ok {
+ try { 1 } catch { 2 }
+ do { 2 }
+} qr/\Qtry() encountered an unexpected argument (2) - perhaps a missing semi-colon before or at/,
+ 'Unterminated try detected';
#!/usr/bin/perl
use strict;
-#use warnings;
+use warnings;
-use Test::More tests => 24;
+use Test::More tests => 28;
BEGIN { use_ok 'Try::Tiny' };
try {
- my $a = 1+1;
+ my $a = 1+1;
} catch {
- fail('Cannot go into catch block because we did not throw an exception')
+ fail('Cannot go into catch block because we did not throw an exception')
} finally {
- pass('Moved into finally from try');
+ pass('Moved into finally from try');
};
try {
- die('Die');
+ die('Die');
} catch {
- ok($_ =~ /Die/, 'Error text as expected');
- pass('Into catch block as we died in try');
+ ok($_ =~ /Die/, 'Error text as expected');
+ pass('Into catch block as we died in try');
} finally {
- pass('Moved into finally from catch');
+ pass('Moved into finally from catch');
};
try {
- die('Die');
+ die('Die');
} finally {
- pass('Moved into finally from catch');
+ pass('Moved into finally from catch');
} catch {
- ok($_ =~ /Die/, 'Error text as expected');
+ ok($_ =~ /Die/, 'Error text as expected');
};
try {
- die('Die');
+ die('Die');
} finally {
- pass('Moved into finally block when try throws an exception and we have no catch block');
+ pass('Moved into finally block when try throws an exception and we have no catch block');
};
try {
};
try {
- try {
- die "foo";
- }
- catch {
- die "bar";
- }
- finally {
- pass("finally called");
- };
+ try {
+ die "foo";
+ }
+ catch {
+ die "bar";
+ }
+ finally {
+ pass("finally called");
+ };
};
$_ = "foo";
try {
- is($_, "foo", "not localized in try");
+ is($_, "foo", "not localized in try");
}
catch {
}
finally {
- is(scalar(@_), 0, "nothing in \@_ (finally)");
- is($_, "foo", "\$_ not localized (finally)");
+ is(scalar(@_), 0, "nothing in \@_ (finally)");
+ is($_, "foo", "\$_ not localized (finally)");
};
is($_, "foo", "same afterwards");
$_ = "foo";
try {
- is($_, "foo", "not localized in try");
- die "bar\n";
+ is($_, "foo", "not localized in try");
+ die "bar\n";
}
catch {
- is($_[0], "bar\n", "error in \@_ (catch)");
- is($_, "bar\n", "error in \$_ (catch)");
+ is($_[0], "bar\n", "error in \@_ (catch)");
+ is($_, "bar\n", "error in \$_ (catch)");
}
finally {
- is(scalar(@_), 1, "error in \@_ (finally)");
- is($_[0], "bar\n", "error in \@_ (finally)");
- is($_, "foo", "\$_ not localized (finally)");
+ is(scalar(@_), 1, "error in \@_ (finally)");
+ is($_[0], "bar\n", "error in \@_ (finally)");
+ is($_, "foo", "\$_ not localized (finally)");
};
is($_, "foo", "same afterwards");
+
+{
+ my @warnings;
+ local $SIG{__WARN__} = sub {
+ $_[0] =~ /\QExecution of finally() block CODE(0x\E.+\Q) resulted in an exception/
+ ? push @warnings, @_
+ : warn @_
+ };
+
+ try {
+ die 'tring'
+ } finally {
+ die 'fin 1'
+ } finally {
+ pass('fin 2 called')
+ } finally {
+ die 'fin 3'
+ };
+
+ is( scalar @warnings, 2, 'warnings from both fatal finally blocks' );
+
+ my @originals = sort map { $_ =~ /Original exception text follows:\n\n(.+)/s } @warnings;
+
+ like $originals[0], qr/fin 1 at/, 'First warning contains original exception';
+ like $originals[1], qr/fin 3 at/, 'Second warning contains original exception';
+}
+
1;
use Test::More;
BEGIN {
- plan skip_all => "Perl 5.10 is required" unless eval { require 5.010 };
- plan tests => 3;
- use_ok("Try::Tiny");
+ plan skip_all => "Perl 5.10 is required" unless eval { require 5.010 };
+ plan tests => 3;
+ use_ok("Try::Tiny");
}
use 5.010;
+no if $] >= 5.017011, warnings => 'experimental::smartmatch';
my ( $error, $topic );
given ("foo") {
- when (qr/./) {
- try {
- die "blah\n";
- } catch {
- $topic = $_;
- $error = $_[0];
- }
- };
+ when (qr/./) {
+ try {
+ die "blah\n";
+ } catch {
+ $topic = $_;
+ $error = $_[0];
+ }
+ };
}
is( $error, "blah\n", "error caught" );
{
- local $TODO = "perhaps a workaround can be found";
- is( $topic, $error, 'error is also in $_' );
+ local $TODO = "perhaps a workaround can be found"
+ if $] < 5.017003;
+ is( $topic, $error, 'error is also in $_' );
}
# ex: set sw=4 et:
#!/usr/bin/perl
use strict;
-#use warnings;
+use warnings;
use Test::More;
BEGIN {
- plan skip_all => "Perl 5.10 required" unless eval { require 5.010; 1 };
- plan tests => 6;
+ plan skip_all => "Perl 5.10 required" unless eval { require 5.010; 1 };
+ plan tests => 6;
}
BEGIN { use_ok 'Try::Tiny' }
use 5.010;
+no if $] >= 5.017011, warnings => 'experimental::smartmatch';
my ( $foo, $bar, $other );
$_ = "magic";
try {
- die "foo";
+ die "foo";
} catch {
- like( $_, qr/foo/ );
+ like( $_, qr/foo/ );
- when (/bar/) { $bar++ };
- when (/foo/) { $foo++ };
- default { $other++ };
+ when (/bar/) { $bar++ };
+ when (/foo/) { $foo++ };
+ default { $other++ };
};
is( $_, "magic", '$_ not clobbered' );