diff --git a/contrib/amcheck/t/001_verify_heapam.pl b/contrib/amcheck/t/001_verify_heapam.pl index ba40f64b58..8e02a8db2a 100644 --- 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 fdef6cb1ff..e8644e1cbc 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 8134c2a62e..8d689b9601 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_ctl/t/004_logrotate.pl b/src/bin/pg_ctl/t/004_logrotate.pl index aa0d64a4f7..13e91f3bc9 100644 --- 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 4f5b8f5a49..1420cfb352 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 8695d22545..dbca56afad 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 c484237d07..968be3952f 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 67a050b9d4..b2a5541557 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 ac581c1c07..9916a36012 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 7bd500ed95..78ef60d3b2 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 9d00e17f9f..3b031addf7 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 78d4ef5b54..66a256208c 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 47cbc95955..3bedeffcae 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',