summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm
blob: d2dd6507e6de8abce5eaf635ae217c95f6f4e51c (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
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
use strict;
use warnings;
package Test::Warnings; # git description: v0.032-4-ge6f3f36
# vim: set ts=8 sts=2 sw=2 tw=100 et :
# ABSTRACT: Test for warnings and the lack of them
# KEYWORDS: testing tests warnings

our $VERSION = '0.033';

use parent 'Exporter';
use Test::Builder;

our @EXPORT_OK = qw(
    allow_warnings allowing_warnings
    had_no_warnings
    warnings warning
    allow_patterns
    disallow_patterns
);
our %EXPORT_TAGS = ( all => \@EXPORT_OK );

my $warnings_allowed;
my $forbidden_warnings_found;
my $done_testing_called;
my $no_end_test;
my $fail_on_warning;
my $report_warnings;
my @collected_warnings;
my @allowed_patterns;

sub import {
    my $class = shift @_;

    my %names; @names{@_} = ();
    # END block will check for this status
    $no_end_test = exists $names{':no_end_test'};
    # __WARN__ handler will check for this status
    $fail_on_warning = exists $names{':fail_on_warning'};
    # Collect and report warnings at the end
    $report_warnings = exists $names{':report_warnings'};

    delete @names{qw(:no_end_test :fail_on_warning :report_warnings)};
    __PACKAGE__->export_to_level(1, $class, keys %names);
}

# swap this out for testing this module only!
my $tb;
sub _builder(;$) {
    if (not @_) {
        $tb ||= Test::Builder->new;
        return $tb;
    }

    $tb = shift;
}

my $_orig_warn_handler = $SIG{__WARN__};
$SIG{__WARN__} = sub {
    if ($warnings_allowed or grep +($_[0] =~ $_), @allowed_patterns) {
        Test::Builder->new->note($_[0]);
    }
    else {
        $forbidden_warnings_found++;
        push @collected_warnings, $_[0] if $report_warnings;

        # TODO: this doesn't handle blessed coderefs... does anyone care?
        goto &$_orig_warn_handler if $_orig_warn_handler
            and (  (ref $_orig_warn_handler eq 'CODE')
                or ($_orig_warn_handler ne 'DEFAULT'
                    and $_orig_warn_handler ne 'IGNORE'
                    and defined &$_orig_warn_handler));

        if ($_[0] =~ /\n$/) {
            warn $_[0];
        } else {
            require Carp;
            Carp::carp($_[0]);
        }
        _builder->ok(0, 'unexpected warning') if $fail_on_warning;
    }
};

sub warnings(;&) {
    # if someone manually does warnings->import in the same namespace this is
    # imported into, this sub will be called.  in that case, just return the
    # string "warnings" so it calls the correct method.
    if (!@_) {
        return 'warnings';
    }
    my $code = shift;
    my @warnings;
    local $SIG{__WARN__} = sub {
        push @warnings, shift;
    };
    $code->();
    @warnings;
}

sub warning(&) {
    my @warnings = &warnings(@_);
    return @warnings == 1 ? $warnings[0] : \@warnings;
}

if (Test::Builder->can('done_testing')) {
    # monkeypatch Test::Builder::done_testing:
    # check for any forbidden warnings, and record that we have done so
    # so we do not check again via END

    no strict 'refs';
    my $orig = *{'Test::Builder::done_testing'}{CODE};
    no warnings 'redefine';
    *{'Test::Builder::done_testing'} = sub {
        # only do this at the end of all tests, not at the end of a subtest
        my $builder = _builder;
        my $in_subtest_sub = $builder->can('in_subtest');
        if (not $no_end_test
            and not ($in_subtest_sub ? $builder->$in_subtest_sub : $builder->parent)) {
            local $Test::Builder::Level = $Test::Builder::Level + 3;
            had_no_warnings('no (unexpected) warnings (via done_testing)');
            $done_testing_called = 1;
        }

        $orig->(@_);
    };
}

if ($INC{'Test2/Tools/Basic.pm'}) {
    # monkeypatch Test2::Tools::Basic::done_testing:
    # check for any forbidden warnings, and record that we have done so
    # so we do not check again via END

    no strict 'refs';
    my $orig = *{'Test2::Tools::Basic::done_testing'}{CODE};
    no warnings 'redefine';
    *{'Test2::Tools::Basic::done_testing'} = sub {
        if (not $no_end_test) {
            # we could use $ctx to create the test, which means not having to adjust Level,
            # but then we need to make _builder Test2-compatible, which seems like a PITA.
            local $Test::Builder::Level = $Test::Builder::Level + 3;
            had_no_warnings('no (unexpected) warnings (via done_testing)');
            $done_testing_called = 1;
        }

        $orig->(@_);
    };
}

END {
    if (not $no_end_test
        and not $done_testing_called
        # skip this if there is no plan and no tests have been run (e.g.
        # compilation tests of this module!)
        and (_builder->expected_tests or _builder->current_test > 0)
    ) {
        local $Test::Builder::Level = $Test::Builder::Level + 1;
        had_no_warnings('no (unexpected) warnings (via END block)');
    }
}

# setter
sub allow_warnings(;$) {
    $warnings_allowed = @_ || defined $_[0] ? $_[0] : 1;
}

# getter
sub allowing_warnings() { $warnings_allowed }

# call at any time to assert no (unexpected) warnings so far
sub had_no_warnings(;$) {
    if ($ENV{PERL_TEST_WARNINGS_ONLY_REPORT_WARNINGS}) {
        $forbidden_warnings_found
            and _builder->diag("Found $forbidden_warnings_found warnings but allowing them because PERL_TEST_WARNINGS_ONLY_REPORT_WARNINGS is set");
    }
    else {
        _builder->ok(!$forbidden_warnings_found, shift || 'no (unexpected) warnings');
    }
    if (($report_warnings or $ENV{PERL_TEST_WARNINGS_ONLY_REPORT_WARNINGS})
          and $forbidden_warnings_found) {
        _builder->diag("Got the following unexpected warnings:");
        for my $i (1 .. @collected_warnings) {
            _builder->diag("  $i: $collected_warnings[ $i - 1 ]");
        }
    }
}

# pass one or more regexes (in qr format)
# when called in void context, lasting effect is universal
# otherwise, returns objects: when they go out of scope, the effect is removed
#   (warning disallowed again).
sub allow_patterns(@) {
  push @allowed_patterns, @_;
  return if not defined wantarray;
  return [ map +Test::Warnings::TemporaryWarning->new($_), @_ ];
}

sub disallow_patterns(@) {
  foreach my $pattern (@_) {
    @allowed_patterns = grep +($_ ne $pattern), @allowed_patterns;
  }
}

package # hide from PAUSE
  Test::Warnings::TemporaryWarning;

sub new {
  my ($class, $pattern) = @_;
  bless \$pattern, $class;
}

sub DESTROY {
  Test::Warnings::disallow_patterns(${$_[0]});
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

Test::Warnings - Test for warnings and the lack of them

=head1 VERSION

version 0.033

=head1 SYNOPSIS

    use Test::More;
    use Test::Warnings;

    pass('yay!');
    done_testing;

emits TAP:

    ok 1 - yay!
    ok 2 - no (unexpected) warnings (via done_testing)
    1..2

and:

    use Test::More tests => 3;
    use Test::Warnings 0.005 ':all';

    pass('yay!');
    like(warning { warn "oh noes!" }, qr/^oh noes/, 'we warned');

emits TAP:

    ok 1 - yay!
    ok 2 - we warned
    ok 3 - no (unexpected) warnings (via END block)
    1..3

=head1 DESCRIPTION

If you've ever tried to use L<Test::NoWarnings> to confirm there are no warnings
generated by your tests, combined with the convenience of C<done_testing> to
not have to declare a
L<test count|Test::More/I love it-when-a-plan-comes-together>,
you'll have discovered that these two features do not play well together,
as the test count will be calculated I<before> the warnings test is run,
resulting in a TAP error. (See C<examples/test_nowarnings.pl> in this
distribution for a demonstration.)

This module is intended to be used as a drop-in replacement for
L<Test::NoWarnings>: it also adds an extra test, but runs this test I<before>
C<done_testing> calculates the test count, rather than after.  It does this by
hooking into C<done_testing> as well as via an C<END> block.  You can declare
a plan, or not, and things will still Just Work.

It is actually equivalent to:

    use Test::NoWarnings 1.04 ':early';

as warnings are still printed normally as they occur.  You are safe, and
enthusiastically encouraged, to perform a global search-replace of the above
with C<use Test::Warnings;> whether or not your tests have a plan.

It can also be used as a replacement for L<Test::Warn>, if you wish to test
the content of expected warnings; read on to find out how.

=head1 FUNCTIONS

The following functions are available for import (not included by default; you
can also get all of them by importing the tag C<:all>):

=head2 C<< allow_warnings([bool]) >> - EXPERIMENTAL - MAY BE REMOVED

When passed a true value, or no value at all, subsequent warnings will not
result in a test failure; when passed a false value, subsequent warnings will
result in a test failure.  Initial value is C<false>.

When warnings are allowed, any warnings will instead be emitted via
L<Test::Builder::note|Test::Builder/Output>.

=head2 C<allowing_warnings> - EXPERIMENTAL - MAY BE REMOVED

Returns whether we are currently allowing warnings (set by C<allow_warnings>
as described above).

=head2 C<< had_no_warnings(<optional test name>) >>

Tests whether there have been any warnings so far, not preceded by an
C<allowing_warnings> call.  It is run
automatically at the end of all tests, but can also be called manually at any
time, as often as desired.

=head2 C<< warnings( { code } ) >>

Given a code block, runs the block and returns a list of all the
(not previously allowed via C<allow_warnings>) warnings issued within.  This
lets you test for the presence of warnings that you not only would I<allow>,
but I<must> be issued.  Testing functions are not provided; given the strings
returned, you can test these yourself using your favourite testing functions,
such as L<Test::More::is|Test::More/is> or L<Test::Deep::cmp_deeply|Test::Deep/cmp_deeply>.

You can use this construct as a replacement for
L<Test::Warn::warnings_are|Test::Warn/warnings_are>:

    is_deeply(
        [ warnings { ... } ],
        [
            'warning message 1',
            'warning message 2',
        ],
        'got expected warnings',
    );

or, to replace L<Test::Warn::warnings_like|Test::Warn/warnings_like>:

    cmp_deeply(
        [ warnings { ... } ],
        bag(    # ordering of messages doesn't matter
            re(qr/warning message 1/),
            re(qr/warning message 2/),
        ),
        'got expected warnings (in any order)',
    );

Warnings generated by this code block are I<NOT> propagated further. However,
since they are returned from this function with their filename and line
numbers intact, you can re-issue them yourself immediately after calling
C<warnings(...)>, if desired.

Note that C<use Test::Warnings 'warnings'> will give you a C<warnings>
subroutine in your namespace (most likely C<main>, if you're writing a test),
so you (or things you load) can't subsequently do C<< warnings->import >> --
it will result in the error: "Not enough arguments for
Test::Warnings::warnings at ..., near "warnings->import"".  To work around
this, either use the fully-qualified form (C<Test::warnings>) or make your
calls to the C<warnings> package first.

=head2 C<< warning( { code } ) >>

Same as C<< warnings( { code } ) >>, except a scalar is always returned - the
single warning produced, if there was one, or an arrayref otherwise -- which
can be more convenient to use than C<warnings()> if you are expecting exactly
one warning.

However, you are advised to capture the result from C<warning()> into a temp
variable so you can dump its value if it doesn't contain what you expect.
e.g. with this test:

    like(
        warning { foo() },
        qr/^this is a warning/,
        'got a warning from foo()',
    );

if you get two warnings (or none) back instead of one, you'll get an
arrayref, which will result in an unhelpful test failure message like:

    #   Failed test 'got a warning from foo()'
    #   at t/mytest.t line 10.
    #                   'ARRAY(0xdeadbeef)'
    #     doesn't match '(?^:^this is a warning)'

So instead, change your test to:

    my $warning = warning { foo() };
    like(
        $warning,
        qr/^this is a warning/,
        'got a warning from foo()',
    ) or diag 'got warning(s): ', explain($warning);

=head2 allow_patterns

  allow_patterns(qr/always allow this warning/);
  {
    my $temp = allow_patterns(qr/only allow in this scope/, qr/another temporary warning/);
    ... stuff ...
  }

Given one or more regular expressions, in C<qr/.../> form, add them to the allow-list (warnings will
be emitted with C<note> rather than triggering the warning handler). If the return value is saved in
a local variable, the warning exemption will only be in effect for that local scope (the addition is
reversed at the end of the scope); otherwise, the effect is global.

=head2 disallow_patterns

Given one or more regular expressions, in C<qr/.../> form, remove it from the allow-list. The
pattern must exactly match a pattern previously provided to L</allow_patterns>.

=head1 IMPORT OPTIONS

=head2 C<:all>

Imports all functions listed above

=head2 C<:no_end_test>

Disables the addition of a C<had_no_warnings> test
via C<END> or C<done_testing>

=head2 C<:fail_on_warning>

=for stopwords unexempted

When used, fail immediately when an unexempted warning is generated (as opposed to waiting until
L</had_no_warnings> or C<done_testing> is called).

I recommend you only turn this option on when debugging a test, to see where a surprise warning is coming from,
and rely on the end-of-tests check otherwise.

=head2 C<:report_warnings>

When used, C<had_no_warnings()> will print all the unexempted warning content, in case it had been suppressed
earlier by other captures (such as L<Test::Output/stderr_like> or L<Capture::Tiny/capture>).

=head1 OTHER OPTIONS

You can temporarily turn off the failure behaviour of this module, swapping it out for reporting
(see C<:report_warnings> above) with:

  $ENV{PERL_TEST_WARNINGS_ONLY_REPORT_WARNINGS} = 1;

This can be useful for working around problematic modules that have warnings in newer Perl versions.

=head1 CAVEATS

=for stopwords smartmatch TODO irc

Sometimes new warnings can appear in Perl that should B<not> block
installation -- for example, smartmatch was recently deprecated in
perl 5.17.11, so now any distribution that uses smartmatch and also
tests for warnings cannot be installed under 5.18.0.  You might want to
consider only making warnings fail tests in an author environment -- you can
do this with the L<if> pragma:

    use if $ENV{AUTHOR_TESTING} || $ENV{RELEASE_TESTING}, 'Test::Warnings';

In future versions of this module, when interfaces are added to test the
content of warnings, there will likely be additional sugar available to
indicate that warnings should be checked only in author tests (or TODO when
not in author testing), but will still provide exported subs.  Comments are
enthusiastically solicited - drop me an email, write up an RT ticket, or come
by C<#perl-qa> on irc!

=for stopwords Achtung

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

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

    warning_like( { ... }, qr/foo/, 'foo appears in the warning' );

If the code in the C<{ ... }> is going to warn with a stack trace with the
arguments to each subroutine in its call stack (for example via C<Carp::cluck>),
the test name, "foo appears in the warning" will itself be matched by the
regex (see F<examples/warning_like.t>).  Instead, write this:

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

=head1 CAVEATS

If you are using another module that sets its own warning handler (for example L<Devel::Confess> or
L<diagnostics>) your results may be mixed, as those handlers will interfere with this module's
ability to properly detect and capture warnings in their original form.

=head1 TO DO (or: POSSIBLE FEATURES COMING IN FUTURE RELEASES)

=over

=item * C<< allow_warnings(qr/.../) >> - allow some warnings and not others

=for stopwords subtest subtests

=item * more sophisticated handling in subtests - if we save some state on the
L<Test::Builder> object itself, we can allow warnings in a subtest and then
the state will revert when the subtest ends, as well as check for warnings at
the end of every subtest via C<done_testing>.

=item * sugar for making failures TODO when testing outside an author
environment

=back

=head1 SEE ALSO

=for stopwords YANWT

=over 4

=item *

L<Test::NoWarnings>

=item *

L<Test::FailWarnings>

=item *

L<blogs.perl.org: YANWT (Yet Another No-Warnings Tester)|http://blogs.perl.org/users/ether/2013/03/yanwt-yet-another-no-warnings-tester.html>

=item *

L<strictures> - which makes all warnings fatal in tests, hence lessening the need for special warning testing

=item *

L<Test::Warn>

=item *

L<Test::Fatal>

=back

=head1 SUPPORT

Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Test-Warnings>
(or L<bug-Test-Warnings@rt.cpan.org|mailto:bug-Test-Warnings@rt.cpan.org>).

There is also a mailing list available for users of this distribution, at
L<http://lists.perl.org/list/perl-qa.html>.

There is also an irc channel available for users of this distribution, at
L<C<#perl> on C<irc.perl.org>|irc://irc.perl.org/#perl-qa>.

I am also usually active on irc, as 'ether' at C<irc.perl.org> and C<irc.libera.chat>.

=head1 AUTHOR

Karen Etheridge <ether@cpan.org>

=head1 CONTRIBUTORS

=for stopwords Graham Knop A. Sinan Unur Leon Timmermans Tina Mueller

=over 4

=item *

Graham Knop <haarg@haarg.org>

=item *

A. Sinan Unur <nanis@cpan.org>

=item *

Leon Timmermans <fawaka@gmail.com>

=item *

Tina Mueller <cpan2@tinita.de>

=back

=head1 COPYRIGHT AND LICENCE

This software is copyright (c) 2013 by Karen Etheridge.

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