#
-# t/test.pl - most of Test::More functionality without the fuss, plus
-# has mappings native_to_latin1 and latin1_to_native so that fewer tests
-# on non ASCII-ish platforms need to be skipped
+# t/test.pl - most of Test::More functionality without the fuss
# NOTE:
#
-# Increment ($x++) has a certain amount of cleverness for things like
+# Do not rely on features found only in more modern Perls here, as some CPAN
+# distributions copy this file and must operate on older Perls. Similarly, keep
+# things, simple as this may be run under fairly broken circumstances. For
+# example, increment ($x++) has a certain amount of cleverness for things like
#
# $x = 'zz';
# $x++; # $x eq 'aaa';
#
-# stands more chance of breaking than just a simple
+# This stands more chance of breaking than just a simple
#
# $x = $x + 1
#
# In this file, we use the latter "Baby Perl" approach, and increment
# will be worked over by t/op/inc.t
-$Level = 1;
+$| = 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 {
}
} else {
my %plan = @_;
+ $plan{skip_all} and skip_all($plan{skip_all});
$n = $plan{tests};
}
_print "1..$n\n" unless $noplan;
return !defined &DynaLoader::boot_DynaLoader;
}
+sub set_up_inc {
+ # Don’t clobber @INC under miniperl
+ @INC = () unless is_miniperl;
+ unshift @INC, @_;
+}
+
sub _comment {
return map { /^#/ ? "$_\n" : "# $_\n" }
map { split /\n/ } @_;
}
}
+sub skip_all_without_unicode_tables { # (but only under miniperl)
+ if (is_miniperl()) {
+ skip_all_if_miniperl("Unicode tables not built yet")
+ unless eval 'require "unicore/UCD.pl"';
+ }
+}
+
sub find_git_or_skip {
my ($source_dir, $reason);
+
+ if ( $ENV{CONTINUOUS_INTEGRATION} && $ENV{WORKSPACE} ) {
+ $source_dir = $ENV{WORKSPACE};
+ if ( -d "${source_dir}/.git" ) {
+ $ENV{GIT_DIR} = "${source_dir}/.git";
+ return $source_dir;
+ }
+ }
+
if (-d '.git') {
$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;
$source_dir = '.'
}
}
- if ($source_dir) {
+ if ($ENV{'PERL_BUILD_PACKAGING'}) {
+ $reason = 'PERL_BUILD_PACKAGING is set';
+ } elsif ($source_dir) {
my $version_string = `git --version`;
if (defined $version_string
&& $version_string =~ /\Agit version (\d+\.\d+\.\d+)(.*)/) {
}
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.
return defined $x ? '"' . display ($x) . '"' : 'undef';
};
+# Support pre-5.10 Perls, for the benefit of CPAN dists that copy this file.
+# Note that chr(90) exists in both ASCII ("Z") and EBCDIC ("!").
+my $chars_template = defined(eval { pack "W*", 90 }) ? "W*" : "U*";
+eval 'sub re::is_regexp { ref($_[0]) eq "Regexp" }'
+ if !defined &re::is_regexp;
+
# keys are the codes \n etc map to, values are 2 char strings such as \n
my %backslash_escape;
-foreach my $x (split //, 'nrtfa\\\'"') {
+foreach my $x (split //, 'enrtfa\\\'"') {
$backslash_escape{ord eval "\"\\$x\""} = "\\$x";
}
# A way to display scalars containing control characters and Unicode.
foreach my $x (@_) {
if (defined $x and not ref $x) {
my $y = '';
- foreach my $c (unpack("U*", $x)) {
+ foreach my $c (unpack($chars_template, $x)) {
if ($c > 255) {
$y = $y . sprintf "\\x{%x}", $c;
} elsif ($backslash_escape{$c}) {
$y = $y . $backslash_escape{$c};
- } else {
- my $z = chr $c; # Maybe we can get away with a literal...
- if ($z =~ /[[:^print:]]/) {
-
- # Use octal for characters traditionally expressed as
- # such: the low controls, which on EBCDIC aren't
- # necessarily the same ones as on ASCII platforms, but
- # are small ordinals, nonetheless
- if ($c <= 037) {
- $z = sprintf "\\%03o", $c;
- } else {
- $z = sprintf "\\x{%x}", $c;
- }
- }
- $y = $y . $z;
+ } elsif ($c < ord " ") {
+ # Use octal for characters with small ordinals that are
+ # traditionally expressed as octal: the controls below
+ # space, which on EBCDIC are almost all the controls, but
+ # on ASCII don't include DEL nor the C1 controls.
+ $y = $y . sprintf "\\%03o", $c;
+ } elsif (chr $c =~ /[[:print:]]/a) {
+ $y = $y . chr $c;
+ }
+ else {
+ $y = $y . sprintf "\\x%02X", $c;
}
}
$x = $y;
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);
}
sub like_yn ($$$@) {
my ($flip, undef, $expected, $name, @mess) = @_;
+
+ # We just accept like(..., qr/.../), not like(..., '...'), and
+ # definitely not like(..., '/.../') like
+ # Test::Builder::maybe_regex() does.
+ unless (re::is_regexp($expected)) {
+ die "PANIC: The value '$expected' isn't a regexp. The like() function needs a qr// pattern, not a string";
+ }
+
my $pass;
$pass = $_[1] =~ /$expected/ if !$flip;
$pass = $_[1] !~ /$expected/ if $flip;
+ my $display_got = $_[1];
+ $display_got = display($display_got);
+ my $display_expected = $expected;
+ $display_expected = display($display_expected);
unless ($pass) {
- unshift(@mess, "# got '$_[1]'\n",
+ unshift(@mess, "# got '$display_got'\n",
$flip
- ? "# expected !~ /$expected/\n" : "# expected /$expected/\n");
+ ? "# expected !~ /$display_expected/\n"
+ : "# expected /$display_expected/\n");
}
local $Level = $Level + 1;
_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, '', @_);
}
# be compatible with Test::More::skip().
sub skip {
my $why = shift;
- my $n = @_ ? shift : 1;
+ my $n = @_ ? shift : 1;
+ my $bad_swap;
+ my $both_zero;
+ {
+ local $^W = 0;
+ $bad_swap = $why > 0 && $n == 0;
+ $both_zero = $why == 0 && $n == 0;
+ }
+ if ($bad_swap || $both_zero || @_) {
+ my $arg = "'$why', '$n'";
+ if (@_) {
+ $arg .= join(", ", '', map { qq['$_'] } @_);
+ }
+ die qq[$0: expected skip(why, count), got skip($arg)\n];
+ }
for (1..$n) {
_print "ok $test # skip $why\n";
$test = $test + 1;
}
sub skip_without_dynamic_extension {
- my ($extension) = @_;
- skip("no dynamic loading on miniperl, no $extension") if is_miniperl();
- return if &_have_dynamic_extension;
- skip("$extension was not built");
+ my $extension = shift;
+ skip("no dynamic loading on miniperl, no extension $extension", @_)
+ if is_miniperl();
+ return if &_have_dynamic_extension($extension);
+ skip("extension $extension was not built", @_);
}
sub todo_skip {
}
}
-# 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';
$runperl = "$ENV{PERL_RUNPERL_DEBUG} $runperl";
}
unless ($args{nolib}) {
- $runperl = $runperl . ' "-I../lib"'; # doublequotes because of VMS
+ $runperl = $runperl . ' "-I../lib" "-I." '; # doublequotes because of VMS
}
if ($args{switches}) {
local $Level = 2;
if (defined $args{prog}) {
die "test.pl:runperl(): both 'prog' and 'progs' cannot be used " . _where()
if defined $args{progs};
- $args{progs} = [$args{prog}]
+ $args{progs} = [split /\n/, $args{prog}, -1]
}
if (defined $args{progs}) {
die "test.pl:runperl(): 'progs' must be an ARRAYREF " . _where()
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;
}
if (defined $args{args}) {
$runperl = _quote_args($runperl, $args{args});
}
- if ($args{stderr} eq 'devnull') {
+ if (exists $args{stderr} && $args{stderr} eq 'devnull') {
$runperl = $runperl . ($is_mswin ? ' 2>nul' : ' 2>/dev/null');
}
elsif ($args{stderr}) {
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.
sub runperl {
die "test.pl:runperl() does not take a hashref"
if ref $_[0] and ref $_[0] eq 'HASH';
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;
if( -f $file ){
_print_stderr "# Couldn't unlink '$file': $!\n";
}else{
- ++$count;
+ $count = $count + 1; # don't use ++
}
}
$count;
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 = "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
return $count;
}
-# This is the temporary file for _fresh_perl
+# This is the temporary file for fresh_perl
my $tmpfile = tempfile();
-sub _fresh_perl {
- my($prog, $action, $expect, $runperl_args, $name) = @_;
+sub fresh_perl {
+ my($prog, $runperl_args) = @_;
+
+ # Run 'runperl' with the complete perl program contained in '$prog', and
+ # arguments in the hash referred to by '$runperl_args'. The results are
+ # returned, with $? set to the exit code. Unless overridden, stderr is
+ # redirected to stdout.
+ #
+ # Placing the program in a file bypasses various sh vagaries
+
+ die sprintf "Second argument to fresh_perl_.* must be hashref of args to fresh_perl (or {})"
+ unless !(defined $runperl_args) || ref($runperl_args) eq 'HASH';
# Given the choice of the mis-parsable {}
# (we want an anon hash, but a borked lexer might think that it's a block)
# 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};
- open TEST, ">$tmpfile" or die "Cannot open $tmpfile: $!";
+ open TEST, '>', $tmpfile or die "Cannot open $tmpfile: $!";
+ binmode TEST, ':utf8' if $runperl_args->{wide_chars};
print TEST $prog;
close TEST or die "Cannot close $tmpfile: $!";
my $results = runperl(%$runperl_args);
- my $status = $?;
-
+ 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;
$results =~ s/\n\n/\n/g;
}
+ $? = $status;
+ return $results;
+}
+
+
+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);
}
# Each program is source code to run followed by an "EXPECT" line, followed
# by the expected output.
#
-# The code to run may begin with a command line switch such as -w or -0777
-# (alphanumerics only), and may contain (note the '# ' on each):
+# The first line of the code to run may be a command line switch such as -wE
+# or -0777 (alphanumerics only; only one cluster, beginning with a minus is
+# allowed). Later lines may contain (note the '# ' on each):
# # TODO reason for todo
# # SKIP reason for skip
# # SKIP ?code to test if this should be skipped
# 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 $found;
while (<$fh>) {
if (/^__END__/) {
- ++$found;
+ $found = $found + 1; # don't use ++
last;
}
}
my $tmpfile = tempfile();
+ my $count_failures = 0;
my ($file, $line);
PROGRAM:
while (defined ($line = shift @prgs)) {
}
}
- my $name = '';
- if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) {
- $name = $1;
- }
+ my $name = '';
+ if ($prog =~ s/^#\s*NAME\s+(.+)\n//m) {
+ $name = $1;
+ } elsif (defined $file) {
+ $name = "test from $file at line $line";
+ }
if ($reason{skip}) {
SKIP:
open my $fh, '>', $tmpfile or die "Cannot open >$tmpfile: $!";
print $fh q{
BEGIN {
+ push @INC, '.';
open STDERR, '>&', STDOUT
or die "Can't dup STDOUT->STDERR: $!;";
}
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";
}
local $::TODO = $reason{todo};
unless ($ok) {
- my $err_line = "PROG: $switch\n$prog\n" .
- "EXPECTED:\n$expected\n";
- $err_line .= "EXIT STATUS: != 0\n" if $fatal;
- $err_line .= "GOT:\n$results\n";
- $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal;
- if ($::TODO) {
- $err_line =~ s/^/# /mg;
- print $err_line; # Harness can't filter it out from STDERR.
- }
- else {
- print STDERR $err_line;
- }
- }
+ my $err_line = '';
+ $err_line .= "FILE: $file ; line $line\n" if defined $file;
+ $err_line .= "PROG: $switch\n$prog\n" .
+ "EXPECTED:\n$expected\n";
+ $err_line .= "EXIT STATUS: != 0\n" if $fatal;
+ $err_line .= "GOT:\n$results\n";
+ $err_line .= "EXIT STATUS: " . ($status >> 8) . "\n" if $fatal;
+ if ($::TODO) {
+ $err_line =~ s/^/# /mg;
+ print $err_line; # Harness can't filter it out from STDERR.
+ }
+ else {
+ print STDERR $err_line;
+ ++$count_failures;
+ die "PERL_TEST_ABORT_FIRST_FAILURE set Test Failure"
+ if $ENV{PERL_TEST_ABORT_FIRST_FAILURE};
+ }
+ }
if (defined $file) {
_ok($ok, "at $file line $line", $name);
File::Path::rmtree $_ if -d $_;
}
}
+
+ if ( $count_failures ) {
+ print STDERR <<'EOS';
+#
+# Note: 'run_multiple_progs' run has one or more failures
+# you can consider setting the environment variable
+# PERL_TEST_ABORT_FIRST_FAILURE=1 before running the test
+# to stop on the first error.
+#
+EOS
+ }
+
+
+ return;
}
sub can_ok ($@) {
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" );
# Written so as to count as one test
local $Level = $Level + 1;
if( ref $class ) {
- ok( 0, "$class is a refrence, not a class name" );
+ ok( 0, "$class is a reference, not a class name" );
}
else {
isa_ok($class, $isa, $class_name);
local @::__capture;
local $SIG {__WARN__} = \&__capture;
+ local $Level = 1;
&$code;
return @::__capture;
}
}
}
-# 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]");
};
my $sig = $is_vms ? 'TERM' : 'KILL';
- my $cmd = _create_runperl( prog => "sleep($timeout);" .
- "warn qq/# $timeout_msg" . '\n/;' .
- "kill($sig, $pid_to_kill);");
- $watchdog = system(1, $cmd);
+ my $prog = "sleep($timeout);" .
+ "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
+ # since the indirect object plus COMMANDSTRING form seems to
+ # hang (see perl #121283). Don't do this on VMS, which doesn't
+ # support the LIST form at all.
+ if ($is_mswin) {
+ my $runperl = which_perl();
+ $runperl =~ /(.*)/;
+ $runperl = $1;
+ if ($runperl =~ m/\s/) {
+ $runperl = qq{"$runperl"};
+ }
+ $watchdog = system({ $runperl } 1, $runperl, '-e', $prog);
+ }
+ else {
+ my $cmd = _create_runperl(prog => $prog);
+ $watchdog = system(1, $cmd);
+ }
};
if ($@ || ($watchdog <= 0)) {
_diag('Failed to start watchdog');
# Add END block to parent to terminate and
# clean up watchdog process
- eval "END { local \$! = 0; local \$? = 0;
- wait() if kill('KILL', $watchdog); };";
+ eval("END { local \$! = 0; local \$? = 0;
+ wait() if kill('KILL', $watchdog); };");
return;
}
# 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
-# The following 2 functions allow tests to work on both EBCDIC and
-# ASCII-ish platforms. They convert string scalars between the native
-# character set and the set of 256 characters which is usually called
-# Latin1.
-
-sub native_to_latin1($) {
- my $string = shift;
-
- return $string if ord('^') == 94; # ASCII, Latin1
- my $output = "";
- for my $i (0 .. length($string) - 1) {
- $output .= chr(ord_native_to_latin1(ord(substr($string, $i, 1))));
- }
- # Preserve utf8ness of input onto the output, even if it didn't need to be
- # utf8
- utf8::upgrade($output) if utf8::is_utf8($string);
-
- return $output;
-}
-
-sub latin1_to_native($) {
- my $string = shift;
+# Orphaned Docker or Linux containers do not necessarily attach to PID 1. They might attach to 0 instead.
+sub is_linux_container {
- return $string if ord('^') == 94; # ASCII, Latin1
- my $output = "";
- for my $i (0 .. length($string) - 1) {
- $output .= chr(ord_latin1_to_native(ord(substr($string, $i, 1))));
+ if ($^O eq 'linux' && open my $fh, '<', '/proc/1/cgroup') {
+ while(<$fh>) {
+ if (m{^\d+:pids:(.*)} && $1 ne '/init.scope') {
+ return 1;
+ }
+ }
}
- # Preserve utf8ness of input onto the output, even if it didn't need to be
- # utf8
- utf8::upgrade($output) if utf8::is_utf8($string);
-
- return $output;
-}
-
-sub ord_latin1_to_native {
- # given an input code point, return the platform's native
- # equivalent value. Anything above latin1 is itself.
-
- my $ord = shift;
- return $ord if ord('^') == 94; # ASCII, Latin1
- return utf8::unicode_to_native($ord);
-}
-
-sub ord_native_to_latin1 {
- # given an input platform code point, return the latin1 equivalent value.
- # Anything above latin1 is itself.
- my $ord = shift;
- return $ord if ord('^') == 94; # ASCII, Latin1
- return utf8::native_to_unicode($ord);
+ return 0;
}
1;
https://perl5.git.perl.org / perl5.git / blobdiff