1package Test2::Tools::Warnings;
2use strict;
3use warnings;
4
5our $VERSION = '0.000143';
6
7use Test2::API qw/context/;
8
9our @EXPORT = qw/warns warning warnings no_warnings/;
10use base 'Exporter';
11
12sub warns(&) {
13    my $code = shift;
14    my $warnings = 0;
15    local $SIG{__WARN__} = sub { $warnings++ };
16    $code->();
17    return $warnings;
18}
19
20sub no_warnings(&) { return !&warns(@_) }
21
22sub warning(&) {
23    my $code = shift;
24    my @warnings;
25    {
26        local $SIG{__WARN__} = sub { push @warnings => @_ };
27        $code->();
28        return unless @warnings;
29    }
30
31    if (@warnings > 1) {
32        my $ctx = context();
33        $ctx->alert("Extra warnings in warning { ... }");
34        $ctx->note($_) for @warnings;
35        $ctx->release;
36    }
37
38    return $warnings[0];
39}
40
41sub warnings(&) {
42    my $code = shift;
43
44    my @warnings;
45    local $SIG{__WARN__} = sub { push @warnings => @_ };
46    $code->();
47
48    return \@warnings;
49}
50
511;
52
53
54__END__
55
56=pod
57
58=encoding UTF-8
59
60=head1 NAME
61
62Test2::Tools::Warnings - Tools to verify warnings.
63
64=head1 DESCRIPTION
65
66This is a collection of tools that can be used to test code that issues
67warnings.
68
69=head1 SYNOPSIS
70
71    use Test2::Tools::Warnings qw/warns warning warnings no_warnings/;
72
73    ok(warns { warn 'a' }, "the code warns");
74    ok(!warns { 1 }, "The code does not warn");
75    is(warns { warn 'a'; warn 'b' }, 2, "got 2 warnings");
76
77    ok(no_warnings { ... }, "code did not warn");
78
79    like(
80        warning { warn 'xxx' },
81        qr/xxx/,
82        "Got expected warning"
83    );
84
85    is(
86        warnings { warn "a\n"; warn "b\n" },
87        [
88            "a\n",
89            "b\n",
90        ],
91        "Got 2 specific warnings"
92    );
93
94=head1 EXPORTS
95
96All subs are exported by default.
97
98=over 4
99
100=item $count = warns { ... }
101
102Returns the count of warnings produced by the block. This will always return 0,
103or a positive integer.
104
105=item $warning = warning { ... }
106
107Returns the first warning generated by the block. If the block produces more
108than one warning, they will all be shown as notes, and an actual warning will tell
109you about it.
110
111=item $warnings_ref = warnings { ... }
112
113Returns an arrayref with all the warnings produced by the block. This will
114always return an array reference. If there are no warnings, this will return an
115empty array reference.
116
117=item $bool = no_warnings { ... }
118
119Return true if the block has no warnings. Returns false if there are warnings.
120
121=back
122
123=head1 SOURCE
124
125The source code repository for Test2-Suite can be found at
126F<https://github.com/Test-More/Test2-Suite/>.
127
128=head1 MAINTAINERS
129
130=over 4
131
132=item Chad Granum E<lt>exodist@cpan.orgE<gt>
133
134=back
135
136=head1 AUTHORS
137
138=over 4
139
140=item Chad Granum E<lt>exodist@cpan.orgE<gt>
141
142=back
143
144=head1 COPYRIGHT
145
146Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
147
148This program is free software; you can redistribute it and/or
149modify it under the same terms as Perl itself.
150
151See F<http://dev.perl.org/licenses/>
152
153=cut
154