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 9bd66c07f46f8d266f4fbf0fb32a34a5ee22a075..39e16356d8296e89262fe3f0ec5e8290c21f4c3b 100644 (file)
--- a/contrib/amcheck/t/001_verify_heapam.pl
+++ b/contrib/amcheck/t/001_verify_heapam.pl
@@ -143,6 +143,8 @@ sub corrupt_first_page
 
 sub detects_heap_corruption
 {
+   local $Test::Builder::Level = $Test::Builder::Level + 1;
+
    my ($function, $testname) = @_;
 
    detects_corruption(
@@ -158,6 +160,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));
@@ -166,6 +170,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));
@@ -181,6 +187,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 2dc5ef5f0796c99131d5f316e4d69fd4f540d524..9b049d7284288911ada0159aa7113bac286a898f 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_verifybackup/t/005_bad_manifest.pl b/src/bin/pg_verifybackup/t/005_bad_manifest.pl
index 9f8a100a716bf85437bd16215a945c6d544904f7..c51428233ab5b384eea1eb0a53337762ec4de95a 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 3c58d50118a7644a7d1c5f8a483b6424fa15092b..f30f693f42095dff86b6f54073e01baf2e673a43 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 27c93abe78f85aec2dc4d8ec5f276bda6f782d1e..1b8ec8e4a1945196744e4eb964a95a7fef71cf09 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 fd9394957f7328070a5b654198635efbc51d0312..655448ccb6d6c92cee7eaf6b871d6b206502f8e7 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 df6fdc20d1e2f5240b40e92c35752aad9c9c8e4d..2a1bc81506baac3cc8bb4b1cb0fc4b27c90f519d 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 84e977bd6d9b493d8ba993e2193da19779d974e1..6f8e321b970457db7600cf07e53d678415e4e588 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 81098dcf00cf18ce63cc1b0686da5b46ea06e86c..0ff9b5d2a6d43627c02aca30fe84454000084dc9 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 3ee012226dacf0e3a3b71ce2b39f707de3bfa03a..900d181788c9ae644a3883f9f3bf7c36fce4dced 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 7f52fe2e9503be2b80bfc39bd25a7e0a0187b064..9cefe04bce6e9f6f6a7d089c331ec68461b67892 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',