From d834ebcf23208b3ae2109c0cae9af077202a27a4 Mon Sep 17 00:00:00 2001
From: Michael Paquier <michael@paquier.xyz>
Date: Tue, 12 Oct 2021 11:16:20 +0900
Subject: [PATCH] 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/YV1CCFwgM1RV1LeS@paquier.xyz
Backpatch-through: 12
---
 contrib/amcheck/t/001_verify_heapam.pl               |  8 ++++++++
 contrib/test_decoding/t/001_repl_stats.pl            |  2 ++
 src/bin/pg_archivecleanup/t/010_pg_archivecleanup.pl |  2 ++
 src/bin/pg_verifybackup/t/005_bad_manifest.pl        |  6 ++++++
 src/bin/psql/t/010_tab_completion.pl                 |  4 ++++
 src/test/kerberos/t/001_auth.pl                      |  2 ++
 src/test/perl/README                                 | 10 +++++++++-
 src/test/recovery/t/001_stream_rep.pl                |  2 ++
 src/test/recovery/t/003_recovery_targets.pl          |  2 ++
 src/test/recovery/t/007_sync_rep.pl                  |  2 ++
 src/test/recovery/t/009_twophase.pl                  |  2 ++
 src/test/recovery/t/018_wal_optimize.pl              |  2 ++
 12 files changed, 43 insertions(+), 1 deletion(-)

diff --git a/contrib/amcheck/t/001_verify_heapam.pl b/contrib/amcheck/t/001_verify_heapam.pl
index 9bd66c07f46..39e16356d82 100644
--- 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 2dc5ef5f079..9b049d72842 100644
--- 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 8134c2a62e8..8d689b9601c 100644
--- 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 9f8a100a716..c51428233ab 100644
--- 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 3c58d50118a..f30f693f420 100644
--- 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 27c93abe78f..1b8ec8e4a19 100644
--- 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 fd9394957f7..655448ccb6d 100644
--- 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 df6fdc20d1e..2a1bc81506b 100644
--- 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 84e977bd6d9..6f8e321b970 100644
--- 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 81098dcf00c..0ff9b5d2a6d 100644
--- 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 3ee012226da..900d181788c 100644
--- 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 7f52fe2e950..9cefe04bce6 100644
--- 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',