t/basic.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 #use warnings;
   5
   6 use Test::More tests => 26;
   7
   8 BEGIN { use_ok 'Try::Tiny' };
   9
  10 sub _eval {
  11         local $@;
  12         local $Test::Builder::Level = $Test::Builder::Level + 2;
  13         return ( scalar(eval { $_[0]->(); 1 }), $@ );
  14 }
  15
  16
  17 sub lives_ok (&$) {
  18         my ( $code, $desc ) = @_;
  19         local $Test::Builder::Level = $Test::Builder::Level + 1;
  20
  21         my ( $ok, $error ) = _eval($code);
  22
  23         ok($ok, $desc );
  24
  25         diag "error: $@" unless $ok;
  26 }
  27
  28 sub throws_ok (&$$) {
  29         my ( $code, $regex, $desc ) = @_;
  30         local $Test::Builder::Level = $Test::Builder::Level + 1;
  31
  32         my ( $ok, $error ) = _eval($code);
  33
  34         if ( $ok ) {
  35                 fail($desc);
  36         } else {
  37                 like($error || '', $regex, $desc );
  38         }
  39 }
  40
  41
  42 my $prev;
  43
  44 lives_ok {
  45         try {
  46                 die "foo";
  47         };
  48 } "basic try";
  49
  50 throws_ok {
  51         try {
  52                 die "foo";
  53         } catch { die $_ };
  54 } qr/foo/, "rethrow";
  55
  56
  57 {
  58         local $@ = "magic";
  59         is( try { 42 }, 42, "try block evaluated" );
  60         is( $@, "magic", '$@ untouched' );
  61 }
  62
  63 {
  64         local $@ = "magic";
  65         is( try { die "foo" }, undef, "try block died" );
  66         is( $@, "magic", '$@ untouched' );
  67 }
  68
  69 {
  70         local $@ = "magic";
  71         like( (try { die "foo" } catch { $_ }), qr/foo/, "catch block evaluated" );
  72         is( $@, "magic", '$@ untouched' );
  73 }
  74
  75 is( scalar(try { "foo", "bar", "gorch" }), "gorch", "scalar context try" );
  76 is_deeply( [ try {qw(foo bar gorch)} ], [qw(foo bar gorch)], "list context try" );
  77
  78 is( scalar(try { die } catch { "foo", "bar", "gorch" }), "gorch", "scalar context catch" );
  79 is_deeply( [ try { die } catch {qw(foo bar gorch)} ], [qw(foo bar gorch)], "list context catch" );
  80
  81
  82 {
  83         my ($sub) = catch { my $a = $_; };
  84         is(ref($sub), 'Try::Tiny::Catch', 'Checking catch subroutine scalar reference is correctly blessed');
  85 }
  86
  87 {
  88         my ($sub) = finally { my $a = $_; };
  89         is(ref($sub), 'Try::Tiny::Finally', 'Checking finally subroutine scalar reference is correctly blessed');
  90 }
  91
  92 lives_ok {
  93         try {
  94                 die "foo";
  95         } catch {
  96                 my $err = shift;
  97
  98                 try {
  99                         like $err, qr/foo/;
 100                 } catch {
 101                         fail("shouldn't happen");
 102                 };
 103
 104                 pass "got here";
 105         }
 106 } "try in try catch block";
 107
 108 throws_ok {
 109         try {
 110                 die "foo";
 111         } catch {
 112                 my $err = shift;
 113
 114                 try { } catch { };
 115
 116                 die "rethrowing $err";
 117         }
 118 } qr/rethrowing foo/, "rethrow with try in catch block";
 119
 120
 121 sub Evil::DESTROY {
 122         eval { "oh noes" };
 123 }
 124
 125 sub Evil::new { bless { }, $_[0] }
 126
 127 {
 128         local $@ = "magic";
 129         local $_ = "other magic";
 130
 131         try {
 132                 my $object = Evil->new;
 133                 die "foo";
 134         } catch {
 135                 pass("catch invoked");
 136                 local $TODO = "i don't think we can ever make this work sanely, maybe with SIG{__DIE__}";
 137                 like($_, qr/foo/);
 138         };
 139
 140         is( $@, "magic", '$@ untouched' );
 141         is( $_, "other magic", '$_ untouched' );
 142 }
 143
 144 {
 145         my ( $caught, $prev );
 146
 147         {
 148                 local $@;
 149
 150                 eval { die "bar\n" };
 151
 152                 is( $@, "bar\n", 'previous value of $@' );
 153
 154                 try {
 155                         die {
 156                                 prev => $@,
 157                         }
 158                 } catch {
 159                         $caught = $_;
 160                         $prev = $@;
 161                 }
 162         }
 163
 164         is_deeply( $caught, { prev => "bar\n" }, 'previous value of $@ available for capture' );
 165         is( $prev, "bar\n", 'previous value of $@ also available in catch block' );
 166 }