From 5062e6e3bde47ad103f40508e05863e14152323d Mon Sep 17 00:00:00 2001 From: Tony Cook Date: Wed, 10 Sep 2025 09:47:03 +1000 Subject: [PATCH 1/2] document t/test.pl I got sick of reverse engineering run_multiple_progs() tests and runperl() arguments each time I needed to use them. There's some documentation in comments inline but it's pretty variable and less accessible than pod. Since (in theory anyway) we want test.pl to exercise as little of perl as possible, the POD doesn't belong in test.pl itself. So I've put this in t/test_pl.pod since it's not really end user documentation that would belong in pod/. --- MANIFEST | 2 + t/test.pl | 2 + t/test_pl.pod | 884 +++++++++++++++++++++++++++++++++++++++++++ t/test_pl/examples.t | 91 +++++ 4 files changed, 979 insertions(+) create mode 100644 t/test_pl.pod create mode 100644 t/test_pl/examples.t diff --git a/MANIFEST b/MANIFEST index e2bd454e2e96..d9153e9c8016 100644 --- a/MANIFEST +++ b/MANIFEST @@ -6682,9 +6682,11 @@ t/run/switchx3.aux Data for switchx.t t/run/todo.t TODO tests t/TEST The regression tester t/test.pl Simple testing library +t/test_pl.pod Documentation for test.pl t/test_pl/_num_to_alpha.t Tests for the simple testing library t/test_pl/can_isa_ok.t Tests for the simple testing library t/test_pl/display.t Tests for the simple testing library +t/test_pl/examples.t Tests for the simple testing library t/test_pl/plan_skip_all.t Tests for the simple testing library t/test_pl/tempfile.t Tests for the simple testing library t/thread_it.pl Run regression tests in a new thread diff --git a/t/test.pl b/t/test.pl index e498038cd618..1810f662fa92 100644 --- a/t/test.pl +++ b/t/test.pl @@ -17,6 +17,8 @@ # # In this file, we use the latter "Baby Perl" approach, and increment # will be worked over by t/op/inc.t +# +# see t/test_pl.pod for documentation # This file sets for its caller $::IS_ASCII and $::IS_EBCDIC appropriately; # and $::devnull to be the string to use to specify /dev/null on this diff --git a/t/test_pl.pod b/t/test_pl.pod new file mode 100644 index 000000000000..02660deac16b --- /dev/null +++ b/t/test_pl.pod @@ -0,0 +1,884 @@ +=encoding utf8 + +=head1 NAME + +test_pl.pod - documentation for t/test.pl + +=head1 SYNOPSIS + + BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc(qw '../lib ...'); + } + + # either: + plan tests => $test_count; + ... tests ... + + # or + ... tests ... + done_testing(); + + # roughly Test::More compatible + # you can omit $name but you really shouldn't + # tests + ok($ok, $name); + is($got, $expected, $name); + isnt($got, $unexpected, $name); + cmp_ok($got, $op, $expected, $name); + like($got, $expected, $name); + unlike($got, $expected, $name); + pass($name); + fail($name); + can_ok($object, @methods); + new_ok($class, \@args, $obj_name); + isa_ok($object, $class, $obj_name); + require_ok($module); # eg "Time::HiRes" not "Time/Hires.pm" + use_ok($module) # eg "Time::HiRes" not "Time/Hires.pm" + local $::TODO = "todo reason"; + + # test utilities + skip($reason, $count); # $count is 1 if omitted + diag(@messages); + note(@messages); + BAIL_OUT($reason); + + # test extensions over Test::More + # you can omit $name but you really shouldn't + within($got, $expected, $range, $name); + refcount_is($got, $expected, $name); + + object_ok($obj, $isa, $obj_name); + class_ok($class, $isa, $class_name); + + warnings_like($subref, \@expect_qr, $name); + warning_is($subref, $expect, $name); + warning_like($subref, $expect_qr, $name); + + fresh_perl_is($code, $expected, \%runperl_args, $name); + fresh_perl_like($code, $expected, \%runperl_args, $name); + + # test tools + my $test_num = curr_test(); + curr_test($new_test_num); + todo_skip($reason, $count); + + # often used from BEGIN + skip_if_miniperl($reason, $count); + skip_all_without_dynamic_extension($extension); # eg "Time::HiRes" + skip_all(@messages); + skip_all_if_miniperl(@messages); + skip_all_without_perlio(); + skip_all_without_config(@config_keys); + skip_all_without_unicode_tables(); + find_git_or_skip("all"); + find_git_or_skip($count); + + # test directory runners (like t/lib/croak.t, lib/warnings.t) + my ($count, @test_progs) = setup_multiple_progs(@files); + run_multiple_progs('', $fh); + run_multiple_progs($up, @test_progs); + + # utilities + my $output = runperl(%runperl_args); + my $output = run_perl(%runperl_args); # purely an alias + + my ($stdout, $stderr) = + runperl_and_capture(\%myenv_changes, \@run_me); + + my @warnings = capture_warnings($subref); # may allow args + +=for comment not really usable + my $clean = untaint_path($1); # $dirty shouldn't be tainted + + watchdog($timeout, $type); # zero timeout clears the watchdog + + my $perl_exe = which_perl(); + + my $count = unlink_all(@filenames); # return value normally ignored + + my $tmpfile = tempfile(); + register_tempfile(@filenames); + unlink_tempfiles(); # done by END, but you can cleanup earlier too + + my $output = fresh_perl($code, \%runperl_args); + + my @pretty = display(@data); + my $pretty_re = display_rx($str); + + if (eq_array(\@one, \@two)) { + ... + } + if (eq_hash(\%one, \%two)) { + ... + } + + unless (is_miniperl()) { + ... + } + if (is_linux_container()) { + ... + } + + # detected configuration + $::IS_ASCII # if an ASCII-ish system, ie. ord("A") == 65 + $::IS_EBCDIC # if an EDCDIC-ish system, ie. ord("A") == 193 + # path to a device that reads nothing and discards writes + # "/dev/null" or "nul" + $::devnull + +=head1 DESCRIPTION + +F provides much of L, and more, but tries not +to exercise too much of the interpreter. + +Some parts do work differently. + +=head1 Test::More differences + +Since F is loaded with C instead of C you need +to call plan(), or the skip_all() function instead of specifying that +on the C line. + +Instead of: + + use Test::More plan => 20; + +you need something like: + + BEGIN { + chdir 't' if -d 't'; + require './test.pl'; + set_up_inc( '../lib' ); + } + plan tests => 20; + +or you can skip the plan and use done_testing(). + +There is no support for subtests. + +The following Test::More functions are provided and they are generally +Test::More compatible: + +=over + +=item ok($ok, $name) + +=item is($got, $expected, $name) + +=item isnt($got, $unexpected, $name) + +=item cmp_ok($got, $op, $expected, $name) + +=item like($got, $expected, $name) + +=item unlike($got, $expected, $name) + +=item pass($name) + +=item fail($name) + +=item can_ok($object, @methods) + +=item $obj = new_ok($class, \@args, $obj_name) + +=item isa_ok($object, $class, $obj_name) + +=item require_ok($module) + +=item use_ok($module) + +=item skip($reason, $count) + +=item diag(@messages) + +=item note(@messages) + +=item BAIL_OUT($reason) + +=item done_testing() + +=back + +=head1 Extended test functions + +These perform some sort of test, in some cases results for multiple +tests are produced: + +=over + +=item within($got, $expected, $range, $name) + +Check C<$got> is within a numeric range. + +Fails if any of C<$got>, C<$expected> or C<$range> is non-numeric. + +If C<$range> is zero, succeeds if C<< $got == $range >>. + +If C<$expected> is zero, succeeds if C<< -$range <= $got <= $range >>. + +Otherwise succeeds if C<< abs($got - $expected)/$expected < $range >>. + + my $pi = 3.14159265; + within(sin($pi/6), 0.5, 0.0001, "sin(PI/6) is sane"); + within(cos($pi), 0, 0.0001, "cos(PI) is sane"); + +=item refcount_is($got, $expected, $name) + +Succeed if the reference count of C<$got> is C<$expected>. + + my $x = 1; + refcount_is(\$x, 1, "only one reference"); + my $ref = \$x; + refcount_is(\$x, 2, "two references"); + +=item object_ok($obj, $isa, $obj_name) + +Succeeds if C<$obj> is a reference and C C<$isa>. + + object_ok(*STDERR{IO}, "IO::Handle", "check STDERR is IO"); + +=item class_ok($class, $isa, $class_name) + +Succeeds if C<$class> is not a reference and C C<$isa>. + + use IO::File; + class_ok("IO::File", "IO::Handle", "Check IO::File is a class"); + +=item warnings_like($subref, \@expect_qr, $name) + +Captures warnings while running C<&$subref> and succeeds if the +warning text from each warning matches the regular expressions in +C<@expect_qr> in sequence. + + warnings_like(sub { my $x; $x+1 }, [ qr/Undefined value/ ], + "undefined value in addition"); + +Produces C< 1 + scalar(@expect_qr) > test results, one for the count +of warnings, and one for each warning checked. + +=item warning_is($subref, $expect, $name) + +Captures warnings while running C<&$subref> and succeeds if either: + +=over + +=item * + +there is only one warning captured and it is precisely C<$expect>. + +=item * + +there were no warnings and C<$expect> is not defined. + +=back + + warning_is(sub { +#line 1 "fake.pl" + my $x; $x+1 +}, "Use of uninitialized value $x in addition (+) at fake.t line 1."); + +=item warning_like($subref, $expect_qr, $name) + +Captures warnings while running C<&$subref> and succeeds if the +warning text matches the regular expression object C<$expect_qr>. + + warning_like(sub { my $x; $x+1 }, + qr/^Use of uninitialized value \$x in addition/, + "undefined value in addition"); + +=item fresh_perl_is($code, $expected, \%runperl_args, $name) + +=item fresh_perl_like($code, $expect_qr, \%runperl_args, $name) + +Run the C<$code> in a new perl process and capture the output. + +fresh_perl_is() succeeds if the output is precisely C<$expect>. + +fresh_perl_like() succeeds if the output matches the regular +expression C<$expect_qr>. + +See L for the details of C<%runperl_args>. + +This uses fresh_perl() under the hood, see that for some other +differences from raw runperl(). + + fresh_perl_is(<<~'CODE', "Hello\n", {}, "test print"); + print "Hello\n"; + CODE + + fresh_perl_like(<<~'CODE', qr/^Hello at/, {}, "test print like"); + die "Hello"; + CODE + +=item setup_multiple_progs(@files) + +Scan the given files for tests to be run by run_multiple_progs(). +This is currently only used by F which itself is used +by most tests that use run_multiple_progs() on other files. + +Test files parsed by setup_multiple_progs() ignore any lines until a +C<__END__> line is found. + +So in general, just use F, see F and +F for examples. + + ($count, @test_progs) = setup_multiple_progs(@files) + +=item run_multiple_progs('', $fh) + +Read and parse tests from C<$fh>, which is typically C<\*DATA>, and +run them per C< run_multiple_progs($up, @test_progs) >. + + run_multiple_progs('', \*DATA); + ... + __END__ + # NAME first multi test + print "One\n"; + EXPECT + One + ######## + # NAME second multi test + die "Two"; + EXPECT + OPTIONS fatal + Two at - line 1. + +=item run_multiple_progs($up, @test_progs) + +Run each of the test programs, testing whether the output, and +optionally the exit value, matches the expected output. + +See L for the details of the format of +each test. + +The tests here should already be parsed into separate tests, ie. they +do not contain the C<########> separators. + +This form is typically only used directly by F and +indirectly by the users of that file, as with F and +F and you should probably do the same. + +=back + +These functions are test utilties - they don't test anything but +either skip on some condition useful when testing perl itself, or +interact with the test engine at a low level: + +=over + +=item my $test_num = curr_test(); + +=item curr_test($new_test_num); + +Return or set the current test number. + +This can be used when dealing with forked processes to ensure child +and parent test numbers are sequential. See F for an +example. + +=item todo_skip($reason, $count); + +Skip and TODO tests. + +=item skip_if_miniperl($reason, $count); + +Skip some tests if F is running the tests, as with +C. + +=item skip_all_without_dynamic_extension($extension); # eg "Time::HiRes" + +Skip all tests if the test is being run by F or if the given +module hasn't been configured to be built. + +=item skip_all(@messages); + +Skip all tests. Also available via plan() as with Test::More. + +=item skip_all_if_miniperl(@messages); + +Skip all tests if the test is being run by F. + +=item skip_all_without_perlio(); + +Skip all tests if perl was built without C, which should no +longer be possible. + +=item skip_all_without_config(@config_keys) + +Skip all tests if any of the supplied C<%Config> keys is false. + +Typically used for testing C or C prefix keys: + + skip_all_without_config("d_fork"); + skip_all_without_config("usethreads"); + skip_all_without_config(qw(d_pipe d_fork d_waitpid d_getppid)); + +=item skip_all_without_unicode_tables(); + +Skip all tests if the unicode tables, used for unicode character +classification, haven't been built yet. + +=item find_git_or_skip("all"); + +=item find_git_or_skip($count); + +Look for the git directory for the perl being tested, if not found, +either skip all tests if called with C<"all">, or skip C<$count> tests. + +Ensures that the git directory is a clone or fork of the Perl 5 +Porters git repository rather than some other repository, such as the +Debian repository. + +Generally used by porting tests to ensure we're working from a git +clone of the master Perl repository. + +=back + +=head1 Utility functions + +=over + +=item runperl(%runperl_args) +=item run_perl(%runperl_args) + +Run a new perl process with the C, C or C +specified in C<%runperl_args>, captures the output and returns that. + +See L below for the many possible arguments. + + my $out = runperl(prog => "print qq(Hello\n)"); + is($out, "Hello\n", "runperl"); + +=item runperl_and_capture(\%myenv_changes, \@run_me) + +Run a new perl process with the given arguments and capture standard +output and standard error separately: + + my ($stdout, $stderr) = + runperl_and_capture($env, [ '-e', 'print $^O' ]); + +This uses fork(), if fork fails it will return an empty standard +output and stanadard error will contain an error message. + +Despite the name this does not use runperl(). + +=item capture_warnings($subref) + +Runs the given code reference with C<$SIG{__WARN__}> hooked to capture +any warnings, and returns those warnings as a list: + + my @warnings = capture_warnings(sub { my $x; $x+1 }); + is(@warnings, 1, "captured one warning"); + like($warnings[0], + qr/^Use of uninitialized value \$x in addition/, + "check undefined value in addition warning"); + +=item untaint_path($1) + +Remote any empty, C<.>, non-existent, or writable by other/all entries +from the supplied path and return the result: + + $ENV{PATH} =~ /(.*)/s; + my $clean = untaint_path($1); + +Note: currently only used by F itself. + +=item watchdog($timeout); + +=item watchdog($timeout, $method); + +Start a watchdog timer for C<$timeout> seconds. If C<$timeout> is +zero then disables any existing watchdog timer. + +The timeout may be scaled by setting C or +C in the environment. If C +is set the scale factor has a minimum of 10. + +The method used to kill on timeout can be selected by C<$method> which +can be: + +=over + +=item * + +empty or omitted - a method is selected automatically. + +=item * + +C - fork() or system(1, ...) a process that will kill the +current process after the timeout expires. + +=item * + +C - alarm() is used to schedule a signal and a handler is +installed to kill the current process. + +=back + +Automatic selection: + +=over + +=item 1. + +If the C module is loaded, create a thread which will exit +the process after the timeout expires. + +=item 2. + +Try the C method, if that fails, try to use a thread as +above. + +=item 3. + +Use the C method. + +=back + +If none of these work no watchdog is set. + + watchdog(10); # top of file + ... + watchdog(0); # one anything that might lockup is done + +=item which_perl() + +Return the path to the perl used to invoke the test script. + + my $perl_exe = which_perl(); + +=item unlink_all(@filenames) + +Unlink all (including all versions on VMS) of the given files. + + my $count = unlink_all(@filenames); + +This returns the count of successful unlinks, but this is usually +ignored. + +=item tempfile() + +Returns the name of a new temporary file. The file is not created and +the returned name does not include a directory. + + my $tmpfile = tempfile(); + +The file is registered for deletion by unlink_tempfiles(). + +=item register_tempfile(@filenames) + +Register a list of files to be deleted by the next call to +unlink_tempfiles(), which is also called at C time. + +=item unlink_tempfiles() + +Unlink any registered temporary files. This is also called by END, +but you can cleanup earlier too. + +=item fresh_perl($code, \%runperl_args) + +Write the given code to a file, run it via runperl() and return the +captured output. + + my $output = fresh_perl($code, \%runperl_args); + +If you don't otherwise specify it fresh_perl() will set C to 1 +in C<%runperl_args> so standard error output will also be included. + +fresh_perl() accepts the following extra arguments in +C<%runperl_arguments>: + +=over + +=item * + +C - the test code is written to the file as UTF-8. + +=item * + +C - if non-zero any whitespace is trimmed from the end +of all lines in the output. eg. C<"abc \ndef\t\n"> would be returned +as C<"abc\ndef\n">. + +=back + +All trailing empty lines are trimmed from the output. + +The filename of the file the code is written to is replaced with C<-> +in the output. + +C and C are case insensitively replaced with +C in the output. + +=item display(@data) + +Returns the contents of C<@data> with non-ASCII or non-printable +characters in each string replaced with an escape sequence. + + my @pretty = display(@data); + +=item display_rx($str) + +Returns the contents of C<$str> escaped in a similar fashion to the +regex debugger. + + my $pretty_re = display_rx($str); + +=item eq_array(\@one, \@two) + +Returns if the contents of the two arrays compare equally as strings. +This is not a deep compare. + + if (eq_array(\@one, \@two)) { + ... + } + +=item eq_hash(\%one, \%two) + +Returns if the contents of the two hashs compare equally as string. This is not a deep compare. + + if (eq_hash(\%one, \%two)) { + ... + } + +=item is_miniperl() + +Returns true if the test script is being run by C. + + unless (is_miniperl()) { + ... + } + +=item is_linux_container() + +Returns true if the test appears to be running in a container. + + if (is_linux_container()) { + ... + } + +=back + +There are also some variables which detect useful configuration: + +=over + +=item C<$::IS_ASCII> + +=item C<$::IS_EBCDIC> + +True if the system is ASCII or EBCDIC respectively. + +=item C<$::devnull> + +The name of the system F equivalent. + +=back + +There's also: + +=over + +=item C<$::FATAL> + +Controls the default fatality for L. + +=back + +=head1 Runperl Arguments + +runperl(), fresh_perl(), fresh_perl_is() and fresh_perl_like() accept +a common set of parameters that are eventually processed by runperl, +these are: + +=over + +=item * + +C - the code to run as a single string. This is split on new +lines and procssed internally like C. ie. + + prog => $str + +is processed like: + + progs => [ split /\n/, $str ] + +=item * + +C - an array reference of code fragments to pass to the new +perl as C<-e> arguments. + +=item * + +C - the name of a file containing perl code to be run by the +new perl. + +=item * + +C - if present, an array reference of extra switches to +supply before or instead of C or C. + +=item * + +C - if true, suppress the C<"-I../lib" "-I."> runperl() +normally adds before the other arguments. + +=item * + +C - if true, this is fed to standard input of the new perl +process via a pipe. + +It set but not true, the process standard input reads from the +platform F equivalent. + +=item * + +C - an arrayref of extra arguments supplied after the switches +and program. + +=item * + +C - if equal to C, standard error is redirected to +the system F equivalent. + +Otherwise if true, standard error is captured along with standard +output. + +Note: fresh_perl() sets this to true if not otherwise provided. + +=item * + +C - if true the generated command-line is written to stderr +before it is executed. + +=back + +fresh_perl(), fresh_perl_is() and fresh_perl_like() also accept +C and C, see L for details. + +C + +=head1 run_multiple_progs() tests + + # NAME my test name + print "Ok\n"; + EXPECT + Ok + ######## + die "Time to die"; + EXPECT + OPTIONS fatal + Time to die at - line 1. + +Test files parsed by setup_multiple_progs() ignore any lines until a +C<__END__> line is found. This includes any test file based on +F. + +Tests are separated by lines containing exactly eight C<#>. + +A test (both code and expected result) can contain text matching +C]CONFLICT/> which is replaced by the C<< <=> >> repeated seven +times. This is used to test perl's conflict marker detection without +invoking git's complaints about it. + +Each test contains test code, followed by a line containing exactly +C followed by the expected output. + +The test code can contain a variety of control lines: + +=over + +=item * + +C< # NAME >I + +Specifies the name of the test, like the second argument to ok(). + +=item * + +C< # NOTE >I + +Completely ignored. + +=item * + +C< # SKIP ? >I + +=item * + +C< # TODO ? >I + +Conditionally TODO or skip() the test. If I evaluates to +a true value the result is used at the TODO or SKIP message, otherwise +the test is not skipped or TODOed. + +=item * + +C< # SKIP > I + +=item * + +C< # TODO > I + +SKIP or TODO the test with the given message. + +=back + +You can specify extra input files for the test, most typically to +define extra codee to be loaded by C. + +=over + +C<--FILE--> I + +... content for filename1 + +C<--FILE--> I + +... content for filename2 + +C<--FILE--> + +... content for the program + +=back + +If this found all but the first entry are written to their given +filenames, and the last entry is the program supplied to fresh_perl(). + +The expected result may include an C