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