t/op/utf8decode.t: Update tests from new source material

[perl5.git] / t / test.pl

diff --git a/t/test.pl b/t/test.pl
index d30214b..cda3840 100644 (file)
--- a/t/test.pl
+++ b/t/test.pl
@@ -4,12 +4,15 @@
 
 # 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
 #
@@ -300,13 +303,19 @@ sub display {
                     $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;
@@ -730,6 +739,7 @@ sub _create_runperl { # Create the string to qx in runperl().
     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';
@@ -1441,7 +1451,7 @@ sub class_ok {
     # 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);
@@ -1579,10 +1589,27 @@ sub watchdog ($;$)
                     _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');
@@ -1593,13 +1620,7 @@ sub 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;
         }