# 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
#
$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;
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;
}