summaryrefslogtreecommitdiff
path: root/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2024-03-15 03:06:35 +0000
committerNorbert Preining <norbert@preining.info>2024-03-15 03:06:35 +0000
commit12679ab7d3c2a210f4123163671b532b8b55d5f9 (patch)
tree0060d13467186ad977f4e73488ee20dd6c0017ab /systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm
parent62170822e034fdd3f81de7274835d0d3b0467100 (diff)
CTAN sync 202403150306
Diffstat (limited to 'systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm')
-rwxr-xr-xsystems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm587
1 files changed, 587 insertions, 0 deletions
diff --git a/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm
new file mode 100755
index 0000000000..d2dd6507e6
--- /dev/null
+++ b/systems/texlive/tlnet/tlpkg/tlperl/site/lib/Test/Warnings.pm
@@ -0,0 +1,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