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

michaelpq · michaelpq · commit f9c4cb686800 · 2021-10-12T11:15:44.000+09:00
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
diff --git 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
@@ -19,6 +19,8 @@
 # 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
@@ -72,6 +72,8 @@ sub create_files
 
 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
@@ -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
@@ -176,6 +176,8 @@
 
 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
@@ -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
@@ -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
@@ -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
@@ -75,6 +75,8 @@
 # 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
@@ -14,6 +14,8 @@
 # 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
@@ -17,6 +17,8 @@
 # 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
@@ -14,6 +14,8 @@
 
 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
@@ -18,6 +18,8 @@
 
 sub check_orphan_relfilenodes
 {
+	local $Test::Builder::Level = $Test::Builder::Level + 1;
+
 	my ($node, $test_name) = @_;
 
 	my $db_oid = $node->safe_psql('postgres',

Original file line number	Diff line number	Diff line change
`@@ -19,6 +19,8 @@`
`19`	`19`	`# Check that replication slot stats are expected.`
`20`	`20`	`sub test_slot_stats`
`21`	`21`	`{`
	`22`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`23`	`+`
`22`	`24`	`my ($node, $expected, $msg) = @_;`
`23`	`25`
`24`	`26`	`my $result = $node->safe_psql(`
Original file line number	Diff line number	Diff line change
`@@ -72,6 +72,8 @@ sub create_files`
`72`	`72`
`73`	`73`	`sub run_check`
`74`	`74`	`{`
	`75`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`76`	`+`
`75`	`77`	`my ($suffix, $test_name) = @_;`
`76`	`78`
`77`	`79`	`create_files();`
Original file line number	Diff line number	Diff line change
`@@ -31,6 +31,8 @@ sub fetch_file_name`
`31`	`31`	`# Check for a pattern in the logs associated to one format.`
`32`	`32`	`sub check_log_pattern`
`33`	`33`	`{`
	`34`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`35`	`+`
`34`	`36`	`my $format = shift;`
`35`	`37`	`my $logfiles = shift;`
`36`	`38`	`my $pattern = shift;`
Original file line number	Diff line number	Diff line change
`@@ -176,6 +176,8 @@`
`176`	`176`
`177`	`177`	`sub test_parse_error`
`178`	`178`	`{`
	`179`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`180`	`+`
`179`	`181`	`my ($test_name, $manifest_contents) = @_;`
`180`	`182`
`181`	`183`	`test_bad_manifest($test_name,`
`@@ -186,6 +188,8 @@ sub test_parse_error`
`186`	`188`
`187`	`189`	`sub test_fatal_error`
`188`	`190`	`{`
	`191`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`192`	`+`
`189`	`193`	`my ($test_name, $manifest_contents) = @_;`
`190`	`194`
`191`	`195`	`test_bad_manifest($test_name, qr/fatal: $test_name/, $manifest_contents);`
`@@ -194,6 +198,8 @@ sub test_fatal_error`
`194`	`198`
`195`	`199`	`sub test_bad_manifest`
`196`	`200`	`{`
	`201`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`202`	`+`
`197`	`203`	`my ($test_name, $regexp, $manifest_contents) = @_;`
`198`	`204`
`199`	`205`	`open(my $fh, '>', "$tempdir/backup_manifest") \|\| die "open: $!";`
Original file line number	Diff line number	Diff line change
`@@ -127,6 +127,8 @@ sub check_completion`
`127`	`127`	`# (won't work if we are inside a string literal!)`
`128`	`128`	`sub clear_query`
`129`	`129`	`{`
	`130`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`131`	`+`
`130`	`132`	`check_completion("\\r\n", qr/postgres=# /, "\\r works");`
`131`	`133`	`return;`
`132`	`134`	`}`
`@@ -136,6 +138,8 @@ sub clear_query`
`136`	`138`	`# than clear_query because we lose evidence in the history file)`
`137`	`139`	`sub clear_line`
`138`	`140`	`{`
	`141`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`142`	`+`
`139`	`143`	`check_completion("\025\n", qr/postgres=# /, "control-U works");`
`140`	`144`	`return;`
`141`	`145`	`}`
Original file line number	Diff line number	Diff line change
`@@ -221,6 +221,8 @@ sub test_access`
`221`	`221`	`# As above, but test for an arbitrary query result.`
`222`	`222`	`sub test_query`
`223`	`223`	`{`
	`224`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`225`	`+`
`224`	`226`	`my ($node, $role, $query, $expected, $gssencmode, $test_name) = @_;`
`225`	`227`
`226`	`228`	`# need to connect over TCP/IP for Kerberos`
Original file line number	Diff line number	Diff line change
`@@ -75,6 +75,8 @@`
`75`	`75`	`# Expect to connect to $target_node (undef for failure) with given $status.`
`76`	`76`	`sub test_target_session_attrs`
`77`	`77`	`{`
	`78`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`79`	`+`
`78`	`80`	`my $node1 = shift;`
`79`	`81`	`my $node2 = shift;`
`80`	`82`	`my $target_node = shift;`
Original file line number	Diff line number	Diff line change
`@@ -14,6 +14,8 @@`
`14`	`14`	`# count to reach $num_rows, yet not later than the recovery target.`
`15`	`15`	`sub test_recovery_standby`
`16`	`16`	`{`
	`17`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`18`	`+`
`17`	`19`	`my $test_name = shift;`
`18`	`20`	`my $node_name = shift;`
`19`	`21`	`my $node_primary = shift;`
Original file line number	Diff line number	Diff line change
`@@ -17,6 +17,8 @@`
`17`	`17`	`# the configuration file is reloaded before the test.`
`18`	`18`	`sub test_sync_state`
`19`	`19`	`{`
	`20`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`21`	`+`
`20`	`22`	`my ($self, $expected, $msg, $setting) = @_;`
`21`	`23`
`22`	`24`	`if (defined($setting))`
Original file line number	Diff line number	Diff line change
`@@ -18,6 +18,8 @@`
`18`	`18`
`19`	`19`	`sub check_orphan_relfilenodes`
`20`	`20`	`{`
	`21`	`+ local $Test::Builder::Level = $Test::Builder::Level + 1;`
	`22`	`+`
`21`	`23`	`my ($node, $test_name) = @_;`
`22`	`24`
`23`	`25`	`my $db_oid = $node->safe_psql('postgres',`