Initial Commit
This commit is contained in:
Riley Schneider
504
database/perl/vendor/lib/Test/Warn.pm
vendored
Normal file
504
database/perl/vendor/lib/Test/Warn.pm
vendored
Normal file
@@ -0,0 +1,504 @@
|
||||
=head1 NAME
|
||||
|
||||
Test::Warn - Perl extension to test methods for warnings
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Warn;
|
||||
|
||||
warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning";
|
||||
warnings_are {bar(1,1)} ["Width very small", "Height very small"];
|
||||
|
||||
warning_is {add(2,2)} undef, "No warnings for calc 2+2"; # or
|
||||
warnings_are {add(2,2)} [], "No warnings for calc 2+2"; # whichever reads better :-)
|
||||
|
||||
warning_like {foo(-dri => "/")} qr/unknown param/i, "an unknown parameter test";
|
||||
warnings_like {bar(1,1)} [qr/width.*small/i, qr/height.*small/i];
|
||||
|
||||
warning_is {foo()} {carped => "didn't find the right parameters"};
|
||||
warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}];
|
||||
|
||||
warning_like {foo(undef)} 'uninitialized';
|
||||
warning_like {bar(file => '/etc/passwd')} 'io';
|
||||
|
||||
warning_like {eval q/"$x"; $x;/}
|
||||
[qw/void uninitialized/],
|
||||
"some warnings at compile time";
|
||||
|
||||
warnings_exist {...} [qr/expected warning/], "Expected warning is thrown";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A good style of Perl programming calls for a lot of diverse regression tests.
|
||||
|
||||
This module provides a few convenience methods for testing warning based-code.
|
||||
|
||||
If you are not already familiar with the L<Test::More> manpage
|
||||
now would be the time to go take a look.
|
||||
|
||||
=head2 FUNCTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<warning_is> I<BLOCK STRING, TEST_NAME>
|
||||
|
||||
Tests that BLOCK gives the specified warning exactly once.
|
||||
|
||||
The test fails if the BLOCK warns more than once or does not warn at all.
|
||||
If the string is undef, then the test succeeds if the BLOCK doesn't
|
||||
give any warning.
|
||||
|
||||
Another way to say that there are no warnings in the block
|
||||
is:
|
||||
|
||||
warnings_are {foo()} [], "no warnings"
|
||||
|
||||
If you want to test for a warning given by Carp
|
||||
you have to write something like:
|
||||
|
||||
warning_is {carp "msg"} {carped => 'msg'}, "Test for a carped warning";
|
||||
|
||||
The test will fail if a "normal" warning is found instead of a "carped" one.
|
||||
|
||||
Note: C<warn "foo"> would print something like C<foo at -e line 1>.
|
||||
This method ignores everything after the "at". Thus to match this warning
|
||||
you would have to call C<< warning_is {warn "foo"} "foo", "Foo succeeded" >>.
|
||||
If you need to test for a warning at an exact line,
|
||||
try something like:
|
||||
|
||||
warning_like {warn "foo"} qr/at XYZ.dat line 5/
|
||||
|
||||
Warn messages with a trailing newline (like C<warn "foo\n">) don't produce the C<at -e line 1> message by Perl.
|
||||
Up to Test::Warn 0.30 such warning weren't supported by C<< warning_is {warn "foo\n"} "foo\n" >>.
|
||||
Starting with version 0.31 they are supported, but also marked as experimental.
|
||||
|
||||
L<C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME> and L<C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME>
|
||||
are only aliases to the same method. So you also could write
|
||||
C<< warning_is {foo()} [], "no warning" >> or something similar.
|
||||
|
||||
I decided to give two methods the same name to improve readability.
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise.
|
||||
|
||||
The test name is optional, but recommended.
|
||||
|
||||
=item B<warnings_are> I<BLOCK ARRAYREF, TEST_NAME>
|
||||
|
||||
Tests to see that BLOCK gives exactly the specified warnings.
|
||||
The test fails if the warnings from BLOCK are not exactly the ones in ARRAYREF.
|
||||
If the ARRAYREF is equal to C<< [] >>,
|
||||
then the test succeeds if the BLOCK doesn't give any warning.
|
||||
|
||||
Please read also the notes to
|
||||
L<C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME>
|
||||
as these methods are only aliases.
|
||||
|
||||
If you want more than one test for carped warnings, try this:
|
||||
|
||||
warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2'];
|
||||
|
||||
or
|
||||
|
||||
warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"];
|
||||
|
||||
Note that C<< {carped => ...} >> must always be a hash ref.
|
||||
|
||||
=item B<warning_like> I<BLOCK REGEXP, TEST_NAME>
|
||||
|
||||
Tests that BLOCK gives exactly one warning and it can be matched by
|
||||
the given regexp.
|
||||
|
||||
If the string is undef, then the tests succeeds if the BLOCK doesn't
|
||||
give any warning.
|
||||
|
||||
The REGEXP is matched against the whole warning line,
|
||||
which in general has the form C<< "WARNING at __FILE__ line __LINE__" >>.
|
||||
So you can check for a warning in the file C<Foo.pm> on line 5 with:
|
||||
|
||||
warning_like {bar()} qr/at Foo.pm line 5/, "Testname"
|
||||
|
||||
I don't know whether it makes sense to do such a test :-(
|
||||
|
||||
However, you should be prepared as a matching with C<'at'>, C<'file'>, C<'\d'>
|
||||
or similar will always pass.
|
||||
|
||||
Consider C<< qr/^foo/ >> if you want to test for warning C<"foo something"> in file F<foo.pl>.
|
||||
|
||||
You can also write the regexp in a string as C<"/.../">
|
||||
instead of using the C<< qr/.../ >> syntax.
|
||||
|
||||
Note that the slashes are important in the string,
|
||||
as strings without slashes are reserved for warning categories
|
||||
(to match warning categories as can be seen in the perllexwarn man page).
|
||||
|
||||
Similar to
|
||||
L<< C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME >> and
|
||||
L<< C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>
|
||||
you can test for warnings via C<carp> with:
|
||||
|
||||
warning_like {bar()} {carped => qr/bar called too early/i};
|
||||
|
||||
Similar to
|
||||
L<< C<warning_is()>|/warning_is-BLOCK-STRING-TEST_NAME >> and
|
||||
L<< C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>,
|
||||
|
||||
L<< C<warning_like()>|/warning_like-BLOCK-REGEXP-TEST_NAME >> and
|
||||
L<< C<warnings_like()>|/warnings_like-BLOCK-ARRAYREF-TEST_NAME >>
|
||||
are only aliases to the same methods.
|
||||
|
||||
A true value is returned if the test succeeds, false otherwise.
|
||||
|
||||
The test name is optional, but recommended.
|
||||
|
||||
=item B<warning_like> I<BLOCK STRING, TEST_NAME>
|
||||
|
||||
Tests whether a BLOCK gives exactly one warning of the passed category.
|
||||
|
||||
The categories are grouped in a tree,
|
||||
like it is expressed in L<perllexwarn>.
|
||||
Also see L</BUGS AND LIMITATIONS>.
|
||||
|
||||
|
||||
Thanks to the grouping in a tree,
|
||||
it's possible to test simply for an 'io' warning,
|
||||
instead of testing for a 'closed|exec|layer|newline|pipe|unopened' warning.
|
||||
|
||||
Note, that warnings occurring at compile time
|
||||
can only be caught in an eval block. So
|
||||
|
||||
warning_like {eval q/"$x"; $x;/}
|
||||
[qw/void uninitialized/],
|
||||
"some warnings at compile time";
|
||||
|
||||
will work, while it wouldn't work without the eval.
|
||||
|
||||
Note, that it isn't possible yet,
|
||||
to test for own categories,
|
||||
created with L<warnings::register>.
|
||||
|
||||
=item B<warnings_like> I<BLOCK ARRAYREF, TEST_NAME>
|
||||
|
||||
Tests to see that BLOCK gives exactly the number of the specified
|
||||
warnings, in the defined order.
|
||||
|
||||
Please read also the notes to
|
||||
L<< C<warning_like()>|/warning_like-BLOCK-REGEXP-TEST_NAME >>
|
||||
as these methods are only aliases.
|
||||
|
||||
Similar to
|
||||
L<< C<warnings_are()>|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>,
|
||||
you can test for multiple warnings via C<carp>
|
||||
and for warning categories, too:
|
||||
|
||||
warnings_like {foo()}
|
||||
[qr/bar warning/,
|
||||
qr/bar warning/,
|
||||
{carped => qr/bar warning/i},
|
||||
'io'
|
||||
],
|
||||
"I hope you'll never have to write a test for so many warnings :-)";
|
||||
|
||||
=item B<warnings_exist> I<BLOCK STRING|ARRAYREF, TEST_NAME>
|
||||
|
||||
Same as warning_like, but will C<< warn() >> all warnings that do not match the supplied regex/category,
|
||||
instead of registering an error. Use this test when you just want to make sure that specific
|
||||
warnings were generated, and couldn't care less if other warnings happened in the same block
|
||||
of code.
|
||||
|
||||
warnings_exist {...} [qr/expected warning/], "Expected warning is thrown";
|
||||
|
||||
warnings_exist {...} ['uninitialized'], "Expected warning is thrown";
|
||||
|
||||
=back
|
||||
|
||||
=head2 EXPORT
|
||||
|
||||
C<warning_is>,
|
||||
C<warnings_are>,
|
||||
C<warning_like>,
|
||||
C<warnings_like>,
|
||||
C<warnings_exist> by default.
|
||||
|
||||
=head1 BUGS AND LIMITATIONS
|
||||
|
||||
Category check is done as C<< qr/category_name/ >>. In some case this works, like for
|
||||
category C<'uninitialized'>. For C<'utf8'> it does not work. Perl does not have a list
|
||||
of warnings, so it is not possible to generate one for C<Test::Warn>.
|
||||
|
||||
If you want to add a warning to a category, send a pull request. Modifications
|
||||
should be done to C<< %warnings_in_category >>. You should look into perl source to check
|
||||
how warning is looking exactly.
|
||||
|
||||
Please note that warnings with newlines inside are very awkward.
|
||||
The only sensible way to handle them is to use the C<warning_like> or
|
||||
C<warnings_like> methods. The background is that there is no
|
||||
really safe way to distinguish between warnings with newlines and a
|
||||
stacktrace.
|
||||
|
||||
If a method has its own warn handler,
|
||||
overwriting C<$SIG{__WARN__}>,
|
||||
my test warning methods won't get these warnings.
|
||||
|
||||
The C<warning_like BLOCK CATEGORY, TEST_NAME> method isn't fully tested.
|
||||
Please take note if you use this this calling style,
|
||||
and report any bugs you find.
|
||||
|
||||
=head2 XS warnings
|
||||
|
||||
As described in https://rt.cpan.org/Ticket/Display.html?id=42070&results=3c71d1b101a730e185691657f3b02f21 or https://github.com/hanfried/test-warn/issues/1 XS warnings might not be caught.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
Have a look to the similar L<Test::Exception> module. L<Test::Trap>
|
||||
|
||||
=head1 THANKS
|
||||
|
||||
Many thanks to Adrian Howard, chromatic and Michael G. Schwern,
|
||||
who have given me a lot of ideas.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright 2002 by Janek Schleicher
|
||||
|
||||
Copyright 2007-2014 by Alexandr Ciornii, L<http://chorny.net/>
|
||||
|
||||
Copyright 2015-2018 by Janek Schleicher
|
||||
|
||||
This library is free software; you can redistribute it and/or modify
|
||||
it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
package Test::Warn;
|
||||
|
||||
use 5.006;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Sub::Uplevel 0.12;
|
||||
|
||||
our $VERSION = '0.36';
|
||||
|
||||
require Exporter;
|
||||
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our %EXPORT_TAGS = ( 'all' => [ qw(
|
||||
@EXPORT
|
||||
) ] );
|
||||
|
||||
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
|
||||
|
||||
our @EXPORT = qw(
|
||||
warning_is warnings_are
|
||||
warning_like warnings_like
|
||||
warnings_exist
|
||||
);
|
||||
|
||||
use Test::Builder;
|
||||
my $Tester = Test::Builder->new;
|
||||
|
||||
{
|
||||
no warnings 'once';
|
||||
*warning_is = *warnings_are;
|
||||
*warning_like = *warnings_like;
|
||||
}
|
||||
|
||||
sub warnings_are (&$;$) {
|
||||
my $block = shift;
|
||||
my @exp_warning = map {_canonical_exp_warning($_)}
|
||||
_to_array_if_necessary( shift() || [] );
|
||||
my $testname = shift;
|
||||
my @got_warning = ();
|
||||
local $SIG{__WARN__} = sub {
|
||||
my ($called_from) = caller(0); # to find out Carping methods
|
||||
push @got_warning, _canonical_got_warning($called_from, shift());
|
||||
};
|
||||
uplevel 1,$block;
|
||||
my $ok = _cmp_is( \@got_warning, \@exp_warning );
|
||||
$Tester->ok( $ok, $testname );
|
||||
$ok or _diag_found_warning(@got_warning),
|
||||
_diag_exp_warning(@exp_warning);
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub warnings_like (&$;$) {
|
||||
my $block = shift;
|
||||
my @exp_warning = map {_canonical_exp_warning($_)}
|
||||
_to_array_if_necessary( shift() || [] );
|
||||
my $testname = shift;
|
||||
my @got_warning = ();
|
||||
local $SIG{__WARN__} = sub {
|
||||
my ($called_from) = caller(0); # to find out Carping methods
|
||||
push @got_warning, _canonical_got_warning($called_from, shift());
|
||||
};
|
||||
uplevel 1,$block;
|
||||
my $ok = _cmp_like( \@got_warning, \@exp_warning );
|
||||
$Tester->ok( $ok, $testname );
|
||||
$ok or _diag_found_warning(@got_warning),
|
||||
_diag_exp_warning(@exp_warning);
|
||||
return $ok;
|
||||
}
|
||||
|
||||
sub warnings_exist (&$;$) {
|
||||
my $block = shift;
|
||||
my @exp_warning = map {_canonical_exp_warning($_)}
|
||||
_to_array_if_necessary( shift() || [] );
|
||||
my $testname = shift;
|
||||
my @got_warning = ();
|
||||
local $SIG{__WARN__} = sub {
|
||||
my ($called_from) = caller(0); # to find out Carping methods
|
||||
my $wrn_text=shift;
|
||||
my $wrn_rec=_canonical_got_warning($called_from, $wrn_text);
|
||||
foreach my $wrn (@exp_warning) {
|
||||
if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) {
|
||||
push @got_warning, $wrn_rec;
|
||||
return;
|
||||
}
|
||||
}
|
||||
warn $wrn_text;
|
||||
};
|
||||
uplevel 1,$block;
|
||||
my $ok = _cmp_like( \@got_warning, \@exp_warning );
|
||||
$Tester->ok( $ok, $testname );
|
||||
$ok or _diag_found_warning(@got_warning),
|
||||
_diag_exp_warning(@exp_warning);
|
||||
return $ok;
|
||||
}
|
||||
|
||||
|
||||
sub _to_array_if_necessary {
|
||||
return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
|
||||
}
|
||||
|
||||
sub _canonical_got_warning {
|
||||
my ($called_from, $msg) = @_;
|
||||
my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn';
|
||||
my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included
|
||||
return {$warn_kind => $warning_stack[0]}; # return only the real message
|
||||
}
|
||||
|
||||
sub _canonical_exp_warning {
|
||||
my ($exp) = @_;
|
||||
if (ref($exp) eq 'HASH') { # could be {carped => ...}
|
||||
my $to_carp = $exp->{carped} or return; # undefined message are ignored
|
||||
return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] }
|
||||
? map({ {carped => $_} } grep {defined $_} @$to_carp)
|
||||
: +{carped => $to_carp};
|
||||
}
|
||||
return {warn => $exp};
|
||||
}
|
||||
|
||||
sub _cmp_got_to_exp_warning {
|
||||
my ($got_kind, $got_msg) = %{ shift() };
|
||||
my ($exp_kind, $exp_msg) = %{ shift() };
|
||||
return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
|
||||
my $cmp;
|
||||
if ($exp_msg =~ /\n$/s) {
|
||||
$cmp = "$got_msg\n" eq $exp_msg;
|
||||
} else {
|
||||
$cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/s;
|
||||
}
|
||||
return $cmp;
|
||||
}
|
||||
|
||||
sub _cmp_got_to_exp_warning_like {
|
||||
my ($got_kind, $got_msg) = %{ shift() };
|
||||
my ($exp_kind, $exp_msg) = %{ shift() };
|
||||
return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
|
||||
if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//'
|
||||
my $cmp = $got_msg =~ /$re/;
|
||||
return $cmp;
|
||||
} else {
|
||||
return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub _cmp_is {
|
||||
my @got = @{ shift() };
|
||||
my @exp = @{ shift() };
|
||||
scalar @got == scalar @exp or return 0;
|
||||
my $cmp = 1;
|
||||
$cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got);
|
||||
return $cmp;
|
||||
}
|
||||
|
||||
sub _cmp_like {
|
||||
my @got = @{ shift() };
|
||||
my @exp = @{ shift() };
|
||||
scalar @got == scalar @exp or return 0;
|
||||
my $cmp = 1;
|
||||
$cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got);
|
||||
return $cmp;
|
||||
}
|
||||
|
||||
sub _diag_found_warning {
|
||||
foreach (@_) {
|
||||
if (ref($_) eq 'HASH') {
|
||||
${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
|
||||
: $Tester->diag("found warning: ${$_}{warn}");
|
||||
} else {
|
||||
$Tester->diag( "found warning: $_" );
|
||||
}
|
||||
}
|
||||
$Tester->diag( "didn't find a warning" ) unless @_;
|
||||
}
|
||||
|
||||
sub _diag_exp_warning {
|
||||
foreach (@_) {
|
||||
if (ref($_) eq 'HASH') {
|
||||
${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}")
|
||||
: $Tester->diag("expected to find warning: ${$_}{warn}");
|
||||
} else {
|
||||
$Tester->diag( "expected to find warning: $_" );
|
||||
}
|
||||
}
|
||||
$Tester->diag( "didn't expect to find a warning" ) unless @_;
|
||||
}
|
||||
|
||||
package Test::Warn::Categorization;
|
||||
|
||||
use Carp;
|
||||
|
||||
my $bits = \%warnings::Bits;
|
||||
my @warnings = sort grep {
|
||||
my $warn_bits = $bits->{$_};
|
||||
#!grep { $_ ne $warn_bits && ($_ & $warn_bits) eq $_ } values %$bits;
|
||||
} keys %$bits;
|
||||
|
||||
# Create a warning name category (e.g. 'utf8') to map to a list of warnings.
|
||||
# The warnings are strings that will be OR'ed together into a
|
||||
# regular expression: qr/...|...|.../.
|
||||
my %warnings_in_category = (
|
||||
'utf8' => ['Wide character in \w+\b',],
|
||||
);
|
||||
|
||||
sub _warning_category_regexp {
|
||||
my $category = shift;
|
||||
my $category_bits = $bits->{$category} or return;
|
||||
my @category_warnings
|
||||
= grep { ($bits->{$_} & $category_bits) eq $bits->{$_} } @warnings;
|
||||
|
||||
my @list =
|
||||
map { exists $warnings_in_category{$_}? (@{ $warnings_in_category{$_}}) : ($_) }
|
||||
@category_warnings;
|
||||
my $re = join "|", @list;
|
||||
return qr/$re/;
|
||||
}
|
||||
|
||||
sub warning_like_category {
|
||||
my ($warning, $category) = @_;
|
||||
my $re = _warning_category_regexp($category) or
|
||||
carp("Unknown warning category '$category'"),return;
|
||||
my $ok = $warning =~ /$re/;
|
||||
return $ok;
|
||||
}
|
||||
|
||||
1;
|
||||
Reference in New Issue
Block a user