Add more $Test::Builder::Level in the TAP tests

Incrementing the level of the call stack reported is useful for
debugging purposes as it allows to control which part of the test is
exactly failing, especially if a test is structured with subroutines
that call routines from Test::More.

This adds more incrementations of $Test::Builder::Level where debugging
gets improved (for example it does not make sense for some paths like
pg_rewind where long subroutines are used).

A note is added to src/test/perl/README about that, based on a
suggestion from Andrew Dunstan and a wording coming from both of us.

Usage of Test::Builder::Level has spread in 12, so a backpatch down to
this version is done.

Reviewed-by: Andrew Dunstan, Peter Eisentraut, Daniel Gustafsson
Discussion: https://postgr.es/m/[email protected]
Backpatch-through: 12

diff --git a/contrib/amcheck/t/001_verify_heapam.pl b/contrib/amcheck/t/001_verify_heapam.pl
index ba40f64b58146a6a1499ddfd740c89b409e319ca..8e02a8db2a38f50eb98fadfebe3fd29ee35bb2b2 100644 (file)
--- a/contrib/amcheck/t/001_verify_heapam.pl
+++ b/contrib/amcheck/t/001_verify_heapam.pl
@@ -209,6 +209,8 @@ sub corrupt_first_page
 
 sub detects_heap_corruption
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($function, $testname) = @_;
 
        detects_corruption(
@@ -224,6 +226,8 @@ sub detects_heap_corruption
 
 sub detects_corruption
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($function, $testname, @re) = @_;
 
        my $result = $node->safe_psql('postgres', qq(SELECT * FROM $function));
@@ -232,6 +236,8 @@ sub detects_corruption
 
 sub detects_no_corruption
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($function, $testname) = @_;
 
        my $result = $node->safe_psql('postgres', qq(SELECT * FROM $function));
@@ -247,6 +253,8 @@ sub detects_no_corruption
 # and should be unique.
 sub check_all_options_uncorrupted
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($relname, $prefix) = @_;
 
        for my $stop (qw(true false))

diff --git a/contrib/test_decoding/t/001_repl_stats.pl b/contrib/test_decoding/t/001_repl_stats.pl
index fdef6cb1ffddc820de9fdeeded405a24a98b51c8..e8644e1cbcd005d5ad38b32873113c9b004ee2bb 100644 (file)
--- a/contrib/test_decoding/t/001_repl_stats.pl
+++ b/contrib/test_decoding/t/001_repl_stats.pl
@@ -19,6 +19,8 @@ $node->start;
 # Check that replication slot stats are expected.
 sub test_slot_stats
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($node, $expected, $msg) = @_;
 
        my $result = $node->safe_psql(

diff --git a/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl b/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl
index 8134c2a62e81cf452f1821d1e35c65049b05f1ce..8d689b9601cee757e4e43bfa62364952736c92dd 100644 (file)
--- a/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl
+++ b/src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl
@@ -72,6 +72,8 @@ command_fails_like(
 
 sub run_check
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($suffix, $test_name) = @_;
 
        create_files();

diff --git a/src/bin/pg_ctl/t/004_logrotate.pl b/src/bin/pg_ctl/t/004_logrotate.pl
index aa0d64a4f79a8a8cb26c6c798527ffcb8ee78b9e..13e91f3bc97e9937c471c8ddc8f069d76b81ab23 100644 (file)
--- a/src/bin/pg_ctl/t/004_logrotate.pl
+++ b/src/bin/pg_ctl/t/004_logrotate.pl
@@ -31,6 +31,8 @@ sub fetch_file_name
 # Check for a pattern in the logs associated to one format.
 sub check_log_pattern
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my $format   = shift;
        my $logfiles = shift;
        my $pattern  = shift;

diff --git a/src/bin/pg_verifybackup/t/005_bad_manifest.pl b/src/bin/pg_verifybackup/t/005_bad_manifest.pl
index 4f5b8f5a4991b2335954369d190b6f10d3248475..1420cfb352c703ddee558b1e55e0b57aad661aec 100644 (file)
--- a/src/bin/pg_verifybackup/t/005_bad_manifest.pl
+++ b/src/bin/pg_verifybackup/t/005_bad_manifest.pl
@@ -176,6 +176,8 @@ EOM
 
 sub test_parse_error
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($test_name, $manifest_contents) = @_;
 
        test_bad_manifest($test_name,
@@ -186,6 +188,8 @@ sub test_parse_error
 
 sub test_fatal_error
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($test_name, $manifest_contents) = @_;
 
        test_bad_manifest($test_name, qr/fatal: $test_name/, $manifest_contents);
@@ -194,6 +198,8 @@ sub test_fatal_error
 
 sub test_bad_manifest
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($test_name, $regexp, $manifest_contents) = @_;
 
        open(my $fh, '>', "$tempdir/backup_manifest") || die "open: $!";

diff --git a/src/bin/psql/t/010_tab_completion.pl b/src/bin/psql/t/010_tab_completion.pl
index 8695d225451cdb30c9935e1c9bf16df346262536..dbca56afadc9a84f0e8ee46afe25205aad8248d9 100644 (file)
--- a/src/bin/psql/t/010_tab_completion.pl
+++ b/src/bin/psql/t/010_tab_completion.pl
@@ -127,6 +127,8 @@ sub check_completion
 # (won't work if we are inside a string literal!)
 sub clear_query
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        check_completion("\\r\n", qr/postgres=# /, "\\r works");
        return;
 }
@@ -136,6 +138,8 @@ sub clear_query
 # than clear_query because we lose evidence in the history file)
 sub clear_line
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        check_completion("\025\n", qr/postgres=# /, "control-U works");
        return;
 }

diff --git a/src/test/kerberos/t/001_auth.pl b/src/test/kerberos/t/001_auth.pl
index c484237d07848ff5e32bdbde93b57686738e2caf..968be3952f4cdb63ea680b40e88d8a83ad8e2ac7 100644 (file)
--- a/src/test/kerberos/t/001_auth.pl
+++ b/src/test/kerberos/t/001_auth.pl
@@ -221,6 +221,8 @@ sub test_access
 # As above, but test for an arbitrary query result.
 sub test_query
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($node, $role, $query, $expected, $gssencmode, $test_name) = @_;
 
        # need to connect over TCP/IP for Kerberos

diff --git a/src/test/perl/README b/src/test/perl/README
index 67a050b9d48aaf3428485b4ef5a1a423bd8f7260..b2a5541557b0dbe83533cd8075393561ebd4abda 100644 (file)
--- a/src/test/perl/README
+++ b/src/test/perl/README
@@ -61,9 +61,17 @@ Test::More::like entails use of the qr// operator.  Avoid Perl 5.8.8 bug
 #39185 by not using the "$" regular expression metacharacter in qr// when also
 using the "/m" modifier.  Instead of "$", use "\n" or "(?=\n|\z)".
 
-Read the Test::More documentation for more on how to write tests:
+Test::Builder::Level controls how far up in the call stack a test will look
+at when reporting a failure.  This should be incremented by any subroutine
+which directly or indirectly calls test routines from Test::More, such as
+ok() or is():
+
+    local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+Read the documentation for more on how to write tests:
 
     perldoc Test::More
+    perldoc Test::Builder
 
 For available PostgreSQL-specific test methods and some example tests read the
 perldoc for the test modules, e.g.:

diff --git a/src/test/recovery/t/001_stream_rep.pl b/src/test/recovery/t/001_stream_rep.pl
index ac581c1c078396f0e9e134b891c62e0a906f1be1..9916a36012c85a685f3b67f8146355f67fd962f2 100644 (file)
--- a/src/test/recovery/t/001_stream_rep.pl
+++ b/src/test/recovery/t/001_stream_rep.pl
@@ -75,6 +75,8 @@ note "testing connection parameter \"target_session_attrs\"";
 # Expect to connect to $target_node (undef for failure) with given $status.
 sub test_target_session_attrs
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my $node1       = shift;
        my $node2       = shift;
        my $target_node = shift;

diff --git a/src/test/recovery/t/003_recovery_targets.pl b/src/test/recovery/t/003_recovery_targets.pl
index 7bd500ed95619adf4df95baae922f45f073ed060..78ef60d3b2d46403d2bac4955b9910b4eb405be1 100644 (file)
--- a/src/test/recovery/t/003_recovery_targets.pl
+++ b/src/test/recovery/t/003_recovery_targets.pl
@@ -14,6 +14,8 @@ use Time::HiRes qw(usleep);
 # count to reach $num_rows, yet not later than the recovery target.
 sub test_recovery_standby
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my $test_name       = shift;
        my $node_name       = shift;
        my $node_primary    = shift;

diff --git a/src/test/recovery/t/007_sync_rep.pl b/src/test/recovery/t/007_sync_rep.pl
index 9d00e17f9f0995555b4a0e383a08c9298535ce3d..3b031addf7667a477307c1f7169bf97f1dd34a48 100644 (file)
--- a/src/test/recovery/t/007_sync_rep.pl
+++ b/src/test/recovery/t/007_sync_rep.pl
@@ -17,6 +17,8 @@ my $check_sql =
 # the configuration file is reloaded before the test.
 sub test_sync_state
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($self, $expected, $msg, $setting) = @_;
 
        if (defined($setting))

diff --git a/src/test/recovery/t/009_twophase.pl b/src/test/recovery/t/009_twophase.pl
index 78d4ef5b54bdf384ff9d3adfb818e05eacb2411b..66a256208c46c6040fd24ccf9ac3431e77d2da2b 100644 (file)
--- a/src/test/recovery/t/009_twophase.pl
+++ b/src/test/recovery/t/009_twophase.pl
@@ -14,6 +14,8 @@ my $psql_rc  = '';
 
 sub configure_and_reload
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($node, $parameter) = @_;
        my $name = $node->name;
 

diff --git a/src/test/recovery/t/018_wal_optimize.pl b/src/test/recovery/t/018_wal_optimize.pl
index 47cbc959554b02e209ebca4552a2397a8347565f..3bedeffcae19c2e13c0e5ffefd9de6036ef91077 100644 (file)
--- a/src/test/recovery/t/018_wal_optimize.pl
+++ b/src/test/recovery/t/018_wal_optimize.pl
@@ -18,6 +18,8 @@ use Test::More tests => 38;
 
 sub check_orphan_relfilenodes
 {
+       local $Test::Builder::Level = $Test::Builder::Level + 1;
+
        my ($node, $test_name) = @_;
 
        my $db_oid = $node->safe_psql('postgres',