summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Fatal.pm
blob: 4fd0e2f361a6ae268375b0efb23eaf7834b02b9b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
use strict;
use warnings;
package Test::Fatal;
# ABSTRACT: incredibly simple helpers for testing code with exceptions
$Test::Fatal::VERSION = '0.016';
#pod =head1 SYNOPSIS
#pod
#pod   use Test::More;
#pod   use Test::Fatal;
#pod
#pod   use System::Under::Test qw(might_die);
#pod
#pod   is(
#pod     exception { might_die; },
#pod     undef,
#pod     "the code lived",
#pod   );
#pod
#pod   like(
#pod     exception { might_die; },
#pod     qr/turns out it died/,
#pod     "the code died as expected",
#pod   );
#pod
#pod   isa_ok(
#pod     exception { might_die; },
#pod     'Exception::Whatever',
#pod     'the thrown exception',
#pod   );
#pod
#pod =head1 DESCRIPTION
#pod
#pod Test::Fatal is an alternative to the popular L<Test::Exception>.  It does much
#pod less, but should allow greater flexibility in testing exception-throwing code
#pod with about the same amount of typing.
#pod
#pod It exports one routine by default: C<exception>.
#pod
#pod B<Achtung!>  C<exception> intentionally does not manipulate the call stack.
#pod User-written test functions that use C<exception> must be careful to avoid
#pod false positives if exceptions use stack traces that show arguments.  For a more
#pod magical approach involving globally overriding C<caller>, see
#pod L<Test::Exception>.
#pod
#pod =cut

use Carp ();
use Try::Tiny 0.07;

use Exporter 5.57 'import';

our @EXPORT    = qw(exception);
our @EXPORT_OK = qw(exception success dies_ok lives_ok);

#pod =func exception
#pod
#pod   my $exception = exception { ... };
#pod
#pod C<exception> takes a bare block of code and returns the exception thrown by
#pod that block.  If no exception was thrown, it returns undef.
#pod
#pod B<Achtung!>  If the block results in a I<false> exception, such as 0 or the
#pod empty string, Test::Fatal itself will die.  Since either of these cases
#pod indicates a serious problem with the system under testing, this behavior is
#pod considered a I<feature>.  If you must test for these conditions, you should use
#pod L<Try::Tiny>'s try/catch mechanism.  (Try::Tiny is the underlying exception
#pod handling system of Test::Fatal.)
#pod
#pod Note that there is no TAP assert being performed.  In other words, no "ok" or
#pod "not ok" line is emitted.  It's up to you to use the rest of C<exception> in an
#pod existing test like C<ok>, C<isa_ok>, C<is>, et cetera.  Or you may wish to use
#pod the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output.
#pod
#pod C<exception> does I<not> alter the stack presented to the called block, meaning
#pod that if the exception returned has a stack trace, it will include some frames
#pod between the code calling C<exception> and the thing throwing the exception.
#pod This is considered a I<feature> because it avoids the occasionally twitchy
#pod C<Sub::Uplevel> mechanism.
#pod
#pod B<Achtung!>  This is not a great idea:
#pod
#pod   sub exception_like(&$;$) {
#pod       my ($code, $pattern, $name) = @_;
#pod       like( &exception($code), $pattern, $name );
#pod   }
#pod
#pod   exception_like(sub { }, qr/foo/, 'foo appears in the exception');
#pod
#pod If the code in the C<...> is going to throw a stack trace with the arguments to
#pod each subroutine in its call stack (for example via C<Carp::confess>,
#pod the test name, "foo appears in the exception" will itself be matched by the
#pod regex.  Instead, write this:
#pod
#pod   like( exception { ... }, qr/foo/, 'foo appears in the exception' );
#pod
#pod If you really want a test function that passes the test name, wrap the
#pod arguments in an array reference to hide the literal text from a stack trace:
#pod
#pod   sub exception_like(&$) {
#pod       my ($code, $args) = @_;
#pod       my ($pattern, $name) = @$args;
#pod       like( &exception($code), $pattern, $name );
#pod   }
#pod
#pod   exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );
#pod
#pod To aid in avoiding the problem where the pattern is seen in the exception
#pod because of the call stack, C<$Carp::MAxArgNums> is locally set to -1 when the
#pod code block is called.  If you really don't want that, set it back to whatever
#pod value you like at the beginning of the code block.  Obviously, this solution
#pod doens't affect all possible ways that args of subroutines in the call stack
#pod might taint the test.  The intention here is to prevent some false passes from
#pod people who didn't read the documentation.  Your punishment for reading it is
#pod that you must consider whether to do anything about this.
#pod
#pod B<Achtung>: One final bad idea:
#pod
#pod   isnt( exception { ... }, undef, "my code died!");
#pod
#pod It's true that this tests that your code died, but you should really test that
#pod it died I<for the right reason>.  For example, if you make an unrelated mistake
#pod in the block, like using the wrong dereference, your test will pass even though
#pod the code to be tested isn't really run at all.  If you're expecting an
#pod inspectable exception with an identifier or class, test that.  If you're
#pod expecting a string exception, consider using C<like>.
#pod
#pod =cut

our ($REAL_TBL, $REAL_CALCULATED_TBL) = (1, 1);

sub exception (&) {
  my $code = shift;

  return try {
    my $incremented = defined $Test::Builder::Level
                    ? $Test::Builder::Level - $REAL_CALCULATED_TBL
                    : 0;
    local $Test::Builder::Level = $REAL_CALCULATED_TBL;
    if ($incremented) {
        # each call to exception adds 5 stack frames
        $Test::Builder::Level += 5;
        for my $i (1..$incremented) {
            # -2 because we want to see it from the perspective of the call to
            # is() within the call to $code->()
            my $caller = caller($Test::Builder::Level - 2);
            if ($caller eq __PACKAGE__) {
                # each call to exception adds 5 stack frames
                $Test::Builder::Level = $Test::Builder::Level + 5;
            }
            else {
                $Test::Builder::Level = $Test::Builder::Level + 1;
            }
        }
    }

    local $REAL_CALCULATED_TBL = $Test::Builder::Level;
    local $Carp::MaxArgNums = -1;
    $code->();
    return undef;
  } catch {
    return $_ if $_;

    my $problem = defined $_ ? 'false' : 'undef';
    Carp::confess("$problem exception caught by Test::Fatal::exception");
  };
}

#pod =func success
#pod
#pod   try {
#pod     should_live;
#pod   } catch {
#pod     fail("boo, we died");
#pod   } success {
#pod     pass("hooray, we lived");
#pod   };
#pod
#pod C<success>, exported only by request, is a L<Try::Tiny> helper with semantics
#pod identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will
#pod only be run if the C<try> block ran without error.
#pod
#pod Although almost any needed exception tests can be performed with C<exception>,
#pod success blocks may sometimes help organize complex testing.
#pod
#pod =cut

sub success (&;@) {
  my $code = shift;
  return finally( sub {
    return if @_; # <-- only run on success
    $code->();
  }, @_ );
}

#pod =func dies_ok
#pod
#pod =func lives_ok
#pod
#pod Exported only by request, these two functions run a given block of code, and
#pod provide TAP output indicating if it did, or did not throw an exception. 
#pod These provide an easy upgrade path for replacing existing unit tests based on
#pod C<Test::Exception>.
#pod
#pod RJBS does not suggest using this except as a convenience while porting tests to
#pod use Test::Fatal's C<exception> routine.
#pod
#pod   use Test::More tests => 2;
#pod   use Test::Fatal qw(dies_ok lives_ok);
#pod
#pod   dies_ok { die "I failed" } 'code that fails';
#pod
#pod   lives_ok { return "I'm still alive" } 'code that does not fail';
#pod
#pod =cut

my $Tester;

# Signature should match that of Test::Exception
sub dies_ok (&;$) {
  my $code = shift;
  my $name = shift;

  require Test::Builder;
  $Tester ||= Test::Builder->new;

  my $tap_pos = $Tester->current_test;

  my $exception = exception( \&$code );

  $name ||= $tap_pos != $Tester->current_test
        ? "...and code should throw an exception"
        : "code should throw an exception";

  my $ok = $Tester->ok( $exception, $name );
  $ok or $Tester->diag( "expected an exception but none was raised" );
  return $ok;
}

sub lives_ok (&;$) {
  my $code = shift;
  my $name = shift;

  require Test::Builder;
  $Tester ||= Test::Builder->new;

  my $tap_pos = $Tester->current_test;

  my $exception = exception( \&$code );

  $name ||= $tap_pos != $Tester->current_test
        ? "...and code should not throw an exception"
        : "code should not throw an exception";

  my $ok = $Tester->ok( ! $exception, $name );
  $ok or $Tester->diag( "expected return but an exception was raised" );
  return $ok;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Fatal - incredibly simple helpers for testing code with exceptions

=head1 VERSION

version 0.016

=head1 SYNOPSIS

  use Test::More;
  use Test::Fatal;

  use System::Under::Test qw(might_die);

  is(
    exception { might_die; },
    undef,
    "the code lived",
  );

  like(
    exception { might_die; },
    qr/turns out it died/,
    "the code died as expected",
  );

  isa_ok(
    exception { might_die; },
    'Exception::Whatever',
    'the thrown exception',
  );

=head1 DESCRIPTION

Test::Fatal is an alternative to the popular L<Test::Exception>.  It does much
less, but should allow greater flexibility in testing exception-throwing code
with about the same amount of typing.

It exports one routine by default: C<exception>.

B<Achtung!>  C<exception> intentionally does not manipulate the call stack.
User-written test functions that use C<exception> must be careful to avoid
false positives if exceptions use stack traces that show arguments.  For a more
magical approach involving globally overriding C<caller>, see
L<Test::Exception>.

=head1 FUNCTIONS

=head2 exception

  my $exception = exception { ... };

C<exception> takes a bare block of code and returns the exception thrown by
that block.  If no exception was thrown, it returns undef.

B<Achtung!>  If the block results in a I<false> exception, such as 0 or the
empty string, Test::Fatal itself will die.  Since either of these cases
indicates a serious problem with the system under testing, this behavior is
considered a I<feature>.  If you must test for these conditions, you should use
L<Try::Tiny>'s try/catch mechanism.  (Try::Tiny is the underlying exception
handling system of Test::Fatal.)

Note that there is no TAP assert being performed.  In other words, no "ok" or
"not ok" line is emitted.  It's up to you to use the rest of C<exception> in an
existing test like C<ok>, C<isa_ok>, C<is>, et cetera.  Or you may wish to use
the C<dies_ok> and C<lives_ok> wrappers, which do provide TAP output.

C<exception> does I<not> alter the stack presented to the called block, meaning
that if the exception returned has a stack trace, it will include some frames
between the code calling C<exception> and the thing throwing the exception.
This is considered a I<feature> because it avoids the occasionally twitchy
C<Sub::Uplevel> mechanism.

B<Achtung!>  This is not a great idea:

  sub exception_like(&$;$) {
      my ($code, $pattern, $name) = @_;
      like( &exception($code), $pattern, $name );
  }

  exception_like(sub { }, qr/foo/, 'foo appears in the exception');

If the code in the C<...> is going to throw a stack trace with the arguments to
each subroutine in its call stack (for example via C<Carp::confess>,
the test name, "foo appears in the exception" will itself be matched by the
regex.  Instead, write this:

  like( exception { ... }, qr/foo/, 'foo appears in the exception' );

If you really want a test function that passes the test name, wrap the
arguments in an array reference to hide the literal text from a stack trace:

  sub exception_like(&$) {
      my ($code, $args) = @_;
      my ($pattern, $name) = @$args;
      like( &exception($code), $pattern, $name );
  }

  exception_like(sub { }, [ qr/foo/, 'foo appears in the exception' ] );

To aid in avoiding the problem where the pattern is seen in the exception
because of the call stack, C<$Carp::MAxArgNums> is locally set to -1 when the
code block is called.  If you really don't want that, set it back to whatever
value you like at the beginning of the code block.  Obviously, this solution
doens't affect all possible ways that args of subroutines in the call stack
might taint the test.  The intention here is to prevent some false passes from
people who didn't read the documentation.  Your punishment for reading it is
that you must consider whether to do anything about this.

B<Achtung>: One final bad idea:

  isnt( exception { ... }, undef, "my code died!");

It's true that this tests that your code died, but you should really test that
it died I<for the right reason>.  For example, if you make an unrelated mistake
in the block, like using the wrong dereference, your test will pass even though
the code to be tested isn't really run at all.  If you're expecting an
inspectable exception with an identifier or class, test that.  If you're
expecting a string exception, consider using C<like>.

=head2 success

  try {
    should_live;
  } catch {
    fail("boo, we died");
  } success {
    pass("hooray, we lived");
  };

C<success>, exported only by request, is a L<Try::Tiny> helper with semantics
identical to L<C<finally>|Try::Tiny/finally>, but the body of the block will
only be run if the C<try> block ran without error.

Although almost any needed exception tests can be performed with C<exception>,
success blocks may sometimes help organize complex testing.

=head2 dies_ok

=head2 lives_ok

Exported only by request, these two functions run a given block of code, and
provide TAP output indicating if it did, or did not throw an exception. 
These provide an easy upgrade path for replacing existing unit tests based on
C<Test::Exception>.

RJBS does not suggest using this except as a convenience while porting tests to
use Test::Fatal's C<exception> routine.

  use Test::More tests => 2;
  use Test::Fatal qw(dies_ok lives_ok);

  dies_ok { die "I failed" } 'code that fails';

  lives_ok { return "I'm still alive" } 'code that does not fail';

=head1 AUTHOR

Ricardo Signes <rjbs@cpan.org>

=head1 CONTRIBUTORS

=for stopwords David Golden Graham Knop Jesse Luehrs Joel Bernstein Karen Etheridge

=over 4

=item *

David Golden <dagolden@cpan.org>

=item *

Graham Knop <haarg@haarg.org>

=item *

Jesse Luehrs <doy@tozt.net>

=item *

Joel Bernstein <joel@fysh.org>

=item *

Karen Etheridge <ether@cpan.org>

=back

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Ricardo Signes.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut