# will be worked over by t/op/inc.t
$| = 1;
-$Level = 1;
+our $Level = 1;
my $test = 1;
my $planned;
my $noplan;
$::IS_ASCII = ord 'A' == 65;
$::IS_EBCDIC = ord 'A' == 193;
-$TODO = 0;
-$NO_ENDING = 0;
-$Tests_Are_Passing = 1;
+# This is 'our' to enable harness to account for TODO-ed tests in
+# overall grade of PASS or FAIL
+our $TODO = 0;
+our $NO_ENDING = 0;
+our $Tests_Are_Passing = 1;
# Use this instead of print to avoid interference while testing globals.
sub _print {
$source_dir = '.';
} elsif (-l 'MANIFEST' && -l 'AUTHORS') {
my $where = readlink 'MANIFEST';
- die "Can't readling MANIFEST: $!" unless defined $where;
+ die "Can't readlink MANIFEST: $!" unless defined $where;
die "Confusing symlink target for MANIFEST, '$where'"
unless $where =~ s!/MANIFEST\z!!;
if (-d "$where/.git") {
}
$source_dir = $where;
}
- } elsif (exists $ENV{GIT_DIR}) {
+ } elsif (exists $ENV{GIT_DIR} || -f '.git') {
my $commit = '8d063cd8450e59ea1c611a2f4f5a21059a2804f1';
my $out = `git rev-parse --verify --quiet '$commit^{commit}'`;
chomp $out;
}
sub _where {
- my @caller = caller($Level);
- return "at $caller[1] line $caller[2]";
+ my (undef, $filename, $lineno) = caller($Level);
+ return "at $filename line $lineno";
}
# DON'T use this for matches. Use like() instead.
unless ($pass) {
unshift(@mess, "# got "._qq($got)."\n",
"# expected "._qq($expected)."\n");
+ if (defined $got and defined $expected and
+ (length($got)>20 or length($expected)>20))
+ {
+ my $p = 0;
+ $p++ while substr($got,$p,1) eq substr($expected,$p,1);
+ push @mess,"# diff at $p\n";
+ push @mess,"# after "._qq(substr($got,$p-40<0 ? 0 : $p-40,40))."\n";
+ push @mess,"# have "._qq(substr($got,$p,40))."\n";
+ push @mess,"# want "._qq(substr($expected,$p,40))."\n";
+ }
}
_ok($pass, _where(), $name, @mess);
}
_ok($pass, _where(), $name, @mess);
}
+sub refcount_is {
+ # Don't unpack first arg; access it directly via $_[0] to avoid creating
+ # another reference and upsetting the refcount
+ my (undef, $expected, $name, @mess) = @_;
+ my $got = &Internals::SvREFCNT($_[0]) + 1; # +1 to account for the & calling style
+ my $pass = $got == $expected;
+ unless ($pass) {
+ unshift @mess, "# got $got references\n" .
+ "# expected $expected\n";
+ }
+ _ok($pass, _where(), $name, @mess);
+}
+
sub pass {
_ok(1, '', @_);
}
}
}
-# runperl - Runs a separate perl interpreter and returns its output.
+# runperl, run_perl - Runs a separate perl interpreter and returns its output.
# Arguments :
# switches => [ command-line switches ]
# nolib => 1 # don't use -I../lib (included by default)
# verbose => print the command line
my $is_mswin = $^O eq 'MSWin32';
-my $is_netware = $^O eq 'NetWare';
my $is_vms = $^O eq 'VMS';
my $is_cygwin = $^O eq 'cygwin';
warn "Trailing & in prog >>$prog<< is not portable";
}
}
- if ($is_mswin || $is_netware || $is_vms) {
+ if ($is_mswin || $is_vms) {
$runperl = $runperl . qq ( -e "$prog" );
}
else {
$args{stdin} =~ s/\n/\\n/g;
$args{stdin} =~ s/\r/\\r/g;
- if ($is_mswin || $is_netware || $is_vms) {
+ if ($is_mswin || $is_vms) {
$runperl = qq{$Perl -e "print qq(} .
$args{stdin} . q{)" | } . $runperl;
}
return $runperl;
}
+# usage:
+# $ENV{PATH} =~ /(.*)/s;
+# local $ENV{PATH} = untaint_path($1);
+sub untaint_path {
+ my $path = shift;
+ my $sep;
+
+ if (! eval {require Config; 1}) {
+ warn "test.pl had problems loading Config: $@";
+ $sep = ':';
+ } else {
+ $sep = $Config::Config{path_sep};
+ }
+
+ $path =
+ join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and
+ ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) }
+ split quotemeta ($sep), $1;
+ if ($is_cygwin) { # Must have /bin under Cygwin
+ if (length $path) {
+ $path = $path . $sep;
+ }
+ $path = $path . '/bin';
+ } elsif (!$is_vms and !length $path) {
+ # empty PATH is the same as a path of "." on *nix so to prevent
+ # tests from dieing under taint we need to return something
+ # absolute. Perhaps "/" would be better? Anything absolute will do.
+ $path = "/usr/bin";
+ }
+
+ $path;
+}
+
# sub run_perl {} is alias to below
# Since this uses backticks to run, it is subject to the rules of the shell.
# Locale settings may pose a problem, depending on the program being run.
if ($tainted) {
# We will assume that if you're running under -T, you really mean to
# run a fresh perl, so we'll brute force launder everything for you
- my $sep;
-
- if (! eval {require Config; 1}) {
- warn "test.pl had problems loading Config: $@";
- $sep = ':';
- } else {
- $sep = $Config::Config{path_sep};
- }
-
my @keys = grep {exists $ENV{$_}} qw(CDPATH IFS ENV BASH_ENV);
local @ENV{@keys} = ();
# Untaint, plus take out . and empty string:
local $ENV{'DCL$PATH'} = $1 if $is_vms && exists($ENV{'DCL$PATH'}) && ($ENV{'DCL$PATH'} =~ /(.*)/s);
- $ENV{PATH} =~ /(.*)/s;
- local $ENV{PATH} =
- join $sep, grep { $_ ne "" and $_ ne "." and -d $_ and
- ($is_mswin or $is_vms or !(stat && (stat _)[2]&0022)) }
- split quotemeta ($sep), $1;
- if ($is_cygwin) { # Must have /bin under Cygwin
- if (length $ENV{PATH}) {
- $ENV{PATH} = $ENV{PATH} . $sep;
- }
- $ENV{PATH} = $ENV{PATH} . '/bin';
- }
+ $ENV{PATH} =~ /(.*)/s;
+ local $ENV{PATH} = untaint_path($1);
$runperl =~ /(.*)/s;
$runperl = $1;
# Nice alias
*run_perl = *run_perl = \&runperl; # shut up "used only once" warning
+# Run perl with specified environment and arguments, return (STDOUT, STDERR)
+# set DEBUG_RUNENV=1 in the environment to debug.
+sub runperl_and_capture {
+ my ($env, $args) = @_;
+
+ my $STDOUT = tempfile();
+ my $STDERR = tempfile();
+ my $PERL = $^X;
+ my $FAILURE_CODE = 119;
+
+ local %ENV = %ENV;
+ delete $ENV{PERLLIB};
+ delete $ENV{PERL5LIB};
+ delete $ENV{PERL5OPT};
+ delete $ENV{PERL_USE_UNSAFE_INC};
+ my $pid = fork;
+ return (0, "Couldn't fork: $!") unless defined $pid; # failure
+ if ($pid) { # parent
+ waitpid $pid,0;
+ my $exit_code = $? ? $? >> 8 : 0;
+ my ($out, $err)= ("", "");
+ local $/;
+ if (open my $stdout, '<', $STDOUT) {
+ $out .= <$stdout>;
+ } else {
+ $err .= "Could not read STDOUT '$STDOUT' file: $!\n";
+ }
+ if (open my $stderr, '<', $STDERR) {
+ $err .= <$stderr>;
+ } else {
+ $err .= "Could not read STDERR '$STDERR' file: $!\n";
+ }
+ if ($exit_code == $FAILURE_CODE) {
+ $err .= "Something went wrong. Received FAILURE_CODE as exit code.\n";
+ }
+ if ($ENV{DEBUG_RUNENV}) {
+ print "OUT: $out\n";
+ print "ERR: $err\n";
+ }
+ return ($out, $err);
+ } elsif (defined $pid) { # child
+ # Just in case the order we update the environment changes how
+ # the environment is set up we sort the keys here for consistency.
+ for my $k (sort keys %$env) {
+ $ENV{$k} = $env->{$k};
+ }
+ if ($ENV{DEBUG_RUNENV}) {
+ print "Child Process $$ Executing:\n$PERL @$args\n";
+ }
+ open STDOUT, '>', $STDOUT
+ or do {
+ print "Failed to dup STDOUT to '$STDOUT': $!";
+ exit $FAILURE_CODE;
+ };
+ open STDERR, '>', $STDERR
+ or do {
+ print "Failed to dup STDERR to '$STDERR': $!";
+ exit $FAILURE_CODE;
+ };
+ exec $PERL, @$args
+ or print STDERR "Failed to exec: ",
+ join(" ",map { "'$_'" } $^X, @$args),
+ ": $!\n";
+ exit $FAILURE_CODE;
+ }
+}
+
sub DIE {
_print_stderr "# @_\n";
exit 1;
my @letters = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z);
# Avoid ++ -- ranges split negative numbers
-sub _num_to_alpha{
+sub _num_to_alpha {
my($num,$max_char) = @_;
return unless $num >= 0;
my $alpha = '';
my $char_count = 0;
- $max_char = 0 if $max_char < 0;
+ $max_char = 0 if !defined($max_char) or $max_char < 0;
while( 1 ){
$alpha = $letters[ $num % 26 ] . $alpha;
}
my %tmpfiles;
-END { unlink_all keys %tmpfiles }
+sub unlink_tempfiles {
+ unlink_all keys %tmpfiles;
+ %tempfiles = ();
+}
+
+END { unlink_tempfiles(); }
+
+
+# NOTE: tempfile() may be used as a module names in our tests
+# so the result must be restricted to only legal characters for a module
+# name.
# A regexp that matches the tempfile names
-$::tempfile_regexp = 'tmp\d+[A-Z][A-Z]?';
+$::tempfile_regexp = 'tmp_[A-Z]+_[A-Z]+';
# Avoid ++, avoid ranges, avoid split //
my $tempfile_count = 0;
+my $max_file_chars = 3;
sub tempfile {
- while(1){
- my $try = (-d "t" ? "t/" : "")."tmp$$";
- my $alpha = _num_to_alpha($tempfile_count,2);
+ # if you change the format returned by tempfile() you MUST change
+ # the $::tempfile_regex define above.
+ my $try_prefix = (-d "t" ? "t/" : "")."tmp_"._num_to_alpha($$);
+ while (1) {
+ my $alpha = _num_to_alpha($tempfile_count,$max_file_chars);
last unless defined $alpha;
- $try = $try . $alpha;
+ my $try = $try_prefix . "_" . $alpha;
$tempfile_count = $tempfile_count + 1;
- # Need to note all the file names we allocated, as a second request may
- # come before the first is created.
+ # Need to note all the file names we allocated, as a second request
+ # may come before the first is created. Also we are avoiding ++ here
+ # so we aren't using the normal idiom for this kind of test.
if (!$tmpfiles{$try} && !-e $try) {
# We have a winner
$tmpfiles{$try} = 1;
return $try;
}
}
- die "Can't find temporary file name starting \"tmp$$\"";
+ die sprintf
+ 'panic: Too many tempfile()s with prefix "%s", limit of %d reached',
+ $try_prefix, 26 ** $max_file_chars;
}
# register_tempfile - Adds a list of files to be removed at the end of the current test file
# it feels like the least-worse thing is to assume that auto-vivification
# works. At least, this is only going to be a run-time failure, so won't
# affect tests using this file but not this function.
+ my $trim= delete $runperl_args->{rtrim_result}; # hide from runperl
$runperl_args->{progfile} ||= $tmpfile;
$runperl_args->{stderr} = 1 unless exists $runperl_args->{stderr};
my $results = runperl(%$runperl_args);
my $status = $?; # Not necessary to save this, but it makes it clear to
# future maintainers.
-
+ $results=~s/[ \t]+\n/\n/g if $trim;
# Clean up the results into something a bit more predictable.
$results =~ s/\n+$//;
$results =~ s/at\s+$::tempfile_regexp\s+line/at - line/g;
sub _fresh_perl {
my($prog, $action, $expect, $runperl_args, $name) = @_;
+ local $Level = $Level + 1;
+
+ # strip trailing whitespace if requested - makes some tests easier
+ $expect=~s/[[:blank:]]+\n/\n/g if $runperl_args->{rtrim_result};
+
my $results = fresh_perl($prog, $runperl_args);
my $status = $?;
# Use the first line of the program as a name if none was given
unless( $name ) {
- ($first_line, $name) = $prog =~ /^((.{1,50}).*)/;
+ (my $first_line, $name) = $prog =~ /^((.{1,50}).*)/;
$name = $name . '...' if length $first_line > length $name;
}
# This will make it so the test author doesn't have to know that.
$expected =~ s/\n+$//;
- local $Level = 2;
+ local $Level = $Level + 1;
_fresh_perl($prog, 'eq', $expected, $runperl_args, $name);
}
sub fresh_perl_like {
my($prog, $expected, $runperl_args, $name) = @_;
- local $Level = 2;
+ local $Level = $Level + 1;
_fresh_perl($prog, '=~', $expected, $runperl_args, $name);
}
# regex - the expected output is a regular expression
# random - all lines match but in any order
# fatal - the code will fail fatally (croak, die)
+# nonfatal - the code is not expected to fail fatally
#
# If the actual output contains a line "SKIPPED" the test will be
# skipped.
# If the global variable $FATAL is true then OPTION fatal is the
# default.
+our $FATAL;
sub _setup_one_file {
my $fh = shift;
# Store the filename as a program that started at line 0.
my $option_regex = 0;
my $option_random = 0;
my $fatal = $FATAL;
- if ($expected =~ s/^OPTIONS? (.+)\n//) {
+ if ($expected =~ s/^OPTIONS? (.+)(?:\n|\Z)//) {
foreach my $option (split(' ', $1)) {
if ($option eq 'regex') { # allow regular expressions
$option_regex = 1;
elsif ($option eq 'fatal') { # perl should fail
$fatal = 1;
}
+ elsif ($option eq 'nonfatal') {
+ # used to turn off default fatal
+ $fatal = 0;
+ }
else {
die "$0: Unknown OPTION '$option'\n";
}
sub new_ok {
my($class, $args, $obj_name) = @_;
$args ||= [];
- $object_name = "The object" unless defined $obj_name;
+ $obj_name = "The object" unless defined $obj_name;
local $Level = $Level + 1;
my $error = $@;
if($ok) {
- object_ok($obj, $class, $object_name);
+ object_ok($obj, $class, $obj_name);
}
else {
ok( 0, "new() died" );
}
}
-# Set a watchdog to timeout the entire test file
+# Set a watchdog to timeout the entire test file. The input seconds is
+# multiplied by $ENV{PERL_TEST_TIME_OUT_FACTOR} (default 1; minimum 1).
+# Set this in your profile for slow boxes, or use it to override the timeout
+# temporarily for debugging.
+#
# NOTE: If the test file uses 'threads', then call the watchdog() function
# _AFTER_ the 'threads' module is loaded.
+{ # Closure
+ my $watchdog;
+ my $watchdog_thread;
+
sub watchdog ($;$)
{
my $timeout = shift;
- my $method = shift || "";
+
+ # If cancelling, use the state variables to know which method was used to
+ # create the watchdog.
+ if ($timeout == 0) {
+ if ($watchdog_thread) {
+ $watchdog_thread->kill('KILL');
+ undef $watch_dog_thread;
+ }
+ elsif ($watchdog) {
+ kill('KILL', $watchdog);
+ undef $watch_dog;
+ }
+ else {
+ alarm(0);
+ }
+
+ return;
+ }
+
+ # Make sure these aren't defined.
+ undef $watchdog;
+ undef $watchdog_thread;
+
+ my $method = shift || "";
+
my $timeout_msg = 'Test process timed out - terminating';
+ # Accept either spelling
+ my $timeout_factor = $ENV{PERL_TEST_TIME_OUT_FACTOR}
+ || $ENV{PERL_TEST_TIMEOUT_FACTOR}
+ || 1;
+ $timeout_factor = 1 if $timeout_factor < 1;
+ $timeout_factor = $1 if $timeout_factor =~ /^(\d+)$/;
+
# Valgrind slows perl way down so give it more time before dying.
- $timeout *= 10 if $ENV{PERL_VALGRIND};
+ $timeout_factor = 10 if $timeout_factor < 10 && $ENV{PERL_VALGRIND};
+
+ $timeout *= $timeout_factor;
my $pid_to_kill = $$; # PID for this process
if (!$threads_on || $method eq "process") {
# On Windows and VMS, try launching a watchdog process
- # using system(1, ...) (see perlport.pod)
+ # using system(1, ...) (see perlport.pod). system() returns
+ # immediately on these platforms with effectively a pid of the new
+ # process
if ($is_mswin || $is_vms) {
# On Windows, try to get the 'real' PID
if ($is_mswin) {
return if ($pid_to_kill <= 0);
# Launch watchdog process
- my $watchdog;
+ undef $watchdog;
eval {
local $SIG{'__WARN__'} = sub {
_diag("Watchdog warning: $_[0]");
"warn qq/# $timeout_msg" . '\n/;' .
"kill(q/$sig/, $pid_to_kill);";
+ # If we're in taint mode PATH will be tainted
+ $ENV{PATH} =~ /(.*)/s;
+ local $ENV{PATH} = untaint_path($1);
+
# On Windows use the indirect object plus LIST form to guarantee
# that perl is launched directly rather than via the shell (see
# perlfunc.pod), and ensure that the LIST has multiple elements
# support the LIST form at all.
if ($is_mswin) {
my $runperl = which_perl();
+ $runperl =~ /(.*)/;
+ $runperl = $1;
if ($runperl =~ m/\s/) {
$runperl = qq{"$runperl"};
}
}
# Try using fork() to generate a watchdog process
- my $watchdog;
+ undef $watchdog;
eval { $watchdog = fork() };
if (defined($watchdog)) {
if ($watchdog) { # Parent process
if ($is_cygwin) {
# sometimes the above isn't enough on cygwin
sleep 1; # wait a little, it might have worked after all
- system("/bin/kill -f $pid_to_kill");
+ system("/bin/kill -f $pid_to_kill") if kill(0, $pid_to_kill);
}
}
# Use a watchdog thread because either 'threads' is loaded,
# or fork() failed
if (eval {require threads; 1}) {
- 'threads'->create(sub {
+ $watchdog_thread = 'threads'->create(sub {
# Load POSIX if available
eval { require POSIX; };
+ $SIG{'KILL'} = sub { threads->exit(); };
+
+ # Detach after the signal handler is set up; the parent knows
+ # not to signal until detached.
+ 'threads'->detach();
+
# Execute the timeout
my $time_left = $timeout;
do {
POSIX::_exit(1) if (defined(&POSIX::_exit));
my $sig = $is_vms ? 'TERM' : 'KILL';
kill($sig, $pid_to_kill);
- })->detach();
+ });
+
+ # Don't proceed until the watchdog has set up its signal handler.
+ # (Otherwise there is a possibility that we will exit with threads
+ # running.) The watchdog tells us the handler is set by detaching
+ # itself. (The 'is_running()' is a fail-safe.)
+ while ( $watchdog_thread->is_running()
+ && ! $watchdog_thread->is_detached())
+ {
+ 'threads'->yield();
+ }
+
return;
}
};
}
}
+} # End closure
# Orphaned Docker or Linux containers do not necessarily attach to PID 1. They might attach to 0 instead.
sub is_linux_container {
https://perl5.git.perl.org / perl5.git / blobdiff