#
-# 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
+# It's best to not features found only in more modern Perls here, as some cpan
+# distributions copy this file and 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
#
foreach my $x (@_) {
if (defined $x and not ref $x) {
my $y = '';
- foreach my $c (unpack("U*", $x)) {
+ foreach my $c (unpack("W*", $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) {
+ if ($z !~ /[^[:^print:][:^ascii:]]/) {
+ # The pattern above is equivalent (by de Morgan's
+ # laws) to:
+ # $z !~ /(?[ [:print:] & [:ascii:] ])/
+ # or, $z is not an ascii printable character
+
+ # 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.
+ if ($c < ord " ") {
$z = sprintf "\\%03o", $c;
} else {
$z = sprintf "\\x{%x}", $c;
my $why = shift;
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 || @_) {
- my $arg = "$why, '$n'";
+ if ($bad_swap || $both_zero || @_) {
+ my $arg = "'$why', '$n'";
if (@_) {
$arg .= join(", ", '', map { qq['$_'] } @_);
}
}
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 {
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()
return $runperl;
}
+# sub run_perl {} is alias to below
sub runperl {
die "test.pl:runperl() does not take a hashref"
if ref $_[0] and ref $_[0] eq 'HASH';
# 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);
_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);";
+
+ # 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();
+ 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
- # Win32 watchdog is launched by cmd.exe shell, so use process group
- # kill, otherwise the watchdog is never killed and harness waits
- # every time for the timeout, #121395
- eval( $is_mswin ?
- "END { local \$! = 0; local \$? = 0;
- wait() if kill('-KILL', $watchdog); };"
- : "END { local \$! = 0; local \$? = 0;
+ eval("END { local \$! = 0; local \$? = 0;
wait() if kill('KILL', $watchdog); };");
return;
}