[tesh] try to load a handy perl module for the windows port

[simgrid.git] / tools / tesh / tesh.pl

diff --git a/tools/tesh/tesh.pl b/tools/tesh/tesh.pl
index 4ae67a0..9db28ba 100755 (executable)
--- a/tools/tesh/tesh.pl
+++ b/tools/tesh/tesh.pl
@@ -1,4 +1,4 @@
-#! /usr/bin/perl
+#! /usr/bin/env perl
 
 # Copyright (c) 2012-2014. The SimGrid Team.
 # All rights reserved.
@@ -29,7 +29,7 @@ my $enable_coverage=0;
 my $diff_tool=0;
 my $diff_tool_tmp_fh=0;
 my $diff_tool_tmp_filename=0;
-my $sort_prefix = 19;
+my $sort_prefix = -1;
 my $tesh_file;
 my $tesh_name;
 my $error=0;
@@ -47,13 +47,16 @@ use Text::ParseWords;
 use IPC::Open3;
 use IO::File;
 
-if($^O eq "linux"){
+# Existing OSes: https://metacpan.org/source/SMUELLER/PathTools-3.47/lib/File/Spec.pm
+if($^O eq "linux" || $^O eq "MacOS"){
     $OS = "UNIX";
-}
-else{
+} elsif ($^O eq "MSWin32") {
     $OS = "WIN";
     $ENV{"PRINTF_EXPONENT_DIGITS"} = "2";
+} else {
+    die "Tesh: Unknown operating system: $^O\n";
 }
+use if $^O eq 'MSWin32', 'Win32::Job';
 
 ##
 ## Command line option handling
@@ -280,7 +283,16 @@ sub exec_cmd {
     die "fork() failed: $!" unless defined $forked;
     if ( $forked == 0 ) { # child
       sleep $time_to_wait;
-      kill(SIGKILL, $cmd{'pid'});
+      if ($OS eq "UNIX") {
+         kill(SIGTERM, $cmd{'pid'});
+         sleep 1;
+         kill(SIGKILL, $cmd{'pid'});
+      } elsif ($OS eq "WIN") {
+         system("TASKKILL /F /T /PID $cmd{'pid'}"); 
+          # /F: Forcefully
+         # /T: Tree kill
+         # /PID: poor soul
+      }
       exit $time_to_wait;
     }
   }
@@ -332,27 +344,38 @@ sub parse_out {
   }
 
   if ($cmd{'sort'}){
+    # Save the unsorted observed output to report it on error.
+    map { push @{$cmd{'unsorted got'}}, $_ } @got;
+
     sub mysort{
         substr($a, 0, $sort_prefix) cmp substr($b, 0, $sort_prefix)
     }
     use sort 'stable';
-    @got = sort mysort @got;
+    if ($sort_prefix>0) {
+       @got = sort mysort @got;
+    } else {
+       @got = sort @got;
+    }      
     while (@got and $got[0] eq "") {
       shift @got;
     }
 
     # Sort the expected output to make it easier to write for humans
     if(defined($cmd{'out'})){
-      @{$cmd{'out'}}=sort mysort @{$cmd{'out'}};
+      if ($sort_prefix>0) {
+         @{$cmd{'out'}} = sort mysort @{$cmd{'out'}};
+      } else {
+         @{$cmd{'out'}} = sort @{$cmd{'out'}};
+      }
       while (@{$cmd{'out'}} and ${$cmd{'out'}}[0] eq "") {
         shift @{$cmd{'out'}};
       }
     }
   }
 
-  #Did we timeout ? If yes, handle it. If not, kill the forked process.
+  # Did we timeout ? If yes, handle it. If not, kill the forked process.
 
-  if($timeout==-1 and $gotret eq "got signal SIGKILL"){
+  if($timeout==-1 and ($gotret eq "got signal SIGTERM" or $gotret eq "got signal SIGKILL")){
     $gotret="return code 0";
     $timeout=1;
     $gotret= "timeout after $time_to_wait sec";
@@ -395,11 +418,17 @@ sub parse_out {
     print "(ignoring the output of <$cmd{'file'}:$cmd{'line'}> as requested)\n"
   }
   if (length $diff) {
-    print "Output of <$cmd{'file'}:$cmd{'line'}> mismatch:\n";
+    print "Output of <$cmd{'file'}:$cmd{'line'}> mismatch".($cmd{'sort'}?" (even after sorting)":"").":\n";
+    map { print "$_\n" } split(/\n/,$diff);
     if ($cmd{'sort'}) {
-       print "WARNING: both the observed output and expected output were sorted as requested\n";
+       print "WARNING: Both the observed output and expected output were sorted as requested.\n";
+       print "WARNING: Output were only sorted using the $sort_prefix first chars.\n"
+         if ($sort_prefix>0);
+       print "WARNING: Use <! output sort 19> to sort by simulated date and process ID only.\n";
+       # print "----8<---------------  Begin of unprocessed observed output (as it should appear in file):\n";
+       # map {print "> $_\n"} @{$cmd{'unsorted got'}};
+       # print "--------------->8----  End of the unprocessed observed output.\n";
     }
-    map { print "$_\n" } split(/\n/,$diff);
 
     print "Test suite `$cmd{'file'}': NOK (<$cmd{'file'}:$cmd{'line'}> output mismatch)\n";
     $error=1;