tools/tesh/tesh.pl

   1 #! /usr/bin/env perl
   2
   3 # Copyright (c) 2012-2015. The SimGrid Team.
   4 # All rights reserved.
   5
   6 # This program is free software; you can redistribute it and/or modify it
   7 # under the terms of the license (GNU LGPL) which comes with this package.
   8 eval 'exec perl -S $0 ${1+"$@"}'
   9   if $running_under_some_shell;
  10
  11 # If you change this file, please stick to the formatting you got with:
  12 # perltidy --backup-and-modify-in-place --maximum-line-length=180 --output-line-ending=unix --cuddled-else
  13
  14 =encoding UTF-8
  15
  16 =head1 NAME
  17
  18 tesh -- testing shell
  19
  20 =head1 SYNOPSIS
  21
  22 B<tesh> [I<options>] I<tesh_file>
  23
  24 =cut
  25
  26 my ($timeout)              = 0;
  27 my ($time_to_wait)         = 0;
  28 my $path                   = $0;
  29 my $enable_coverage        = 0;
  30 my $diff_tool              = 0;
  31 my $diff_tool_tmp_fh       = 0;
  32 my $diff_tool_tmp_filename = 0;
  33 my $sort_prefix            = -1;
  34 my $tesh_file;
  35 my $tesh_name;
  36 my $error    = 0;
  37 my $exitcode = 0;
  38 my @bg_cmds;
  39 my (%environ);
  40 $SIG{'PIPE'} = 'IGNORE';
  41 $path =~ s|[^/]*$||;
  42 push @INC, $path;
  43
  44 use Getopt::Long qw(GetOptions);
  45 use strict;
  46 use Text::ParseWords;
  47 use IPC::Open3;
  48 use IO::File;
  49 use English;
  50
  51 ##
  52 ## Portability bits for windows
  53 ##
  54
  55 use constant RUNNING_ON_WINDOWS => ( $OSNAME =~ /^(?:mswin|dos|os2)/oi );
  56 use POSIX qw(:sys_wait_h WIFEXITED WIFSIGNALED WIFSTOPPED WEXITSTATUS WTERMSIG WSTOPSIG
  57   :signal_h SIGINT SIGTERM SIGKILL SIGABRT SIGSEGV);
  58
  59 # These are not implemented on windows
  60 BEGIN {
  61     if (RUNNING_ON_WINDOWS) {
  62         *WIFEXITED   = sub { not $_[0] & 127 };
  63         *WEXITSTATUS = sub { $_[0] >> 8 };
  64         *WIFSIGNALED = sub { ( $_[0] & 127 ) && ( $_[0] & 127 != 127 ) };
  65         *WTERMSIG    = sub { $_[0] & 127 };
  66     }
  67 }
  68
  69 ##
  70 ## Command line option handling
  71 ##
  72
  73 if ( $ARGV[0] eq "--internal-killer-process" ) {
  74
  75     # We fork+exec a waiter process in charge of killing the command after timeout
  76     # If the command stops earlier, that's fine: the killer sends a signal to an already stopped process, fails, and quits.
  77     #    Nobody cares about the killer issues.
  78     #    The only problem could arise if another process is given the same PID than cmd. We bet it won't happen :)
  79     my $time_to_wait = $ARGV[1];
  80     my $pid          = $ARGV[2];
  81     sleep $time_to_wait;
  82     kill( 'TERM', $pid );
  83     sleep 1;
  84     kill( 'KILL', $pid );
  85     exit $time_to_wait;
  86 }
  87
  88 sub var_subst {
  89     my ( $text, $name, $value ) = @_;
  90     if ($value) {
  91         $text =~ s/\${$name(?::[=-][^}]*)?}/$value/g;
  92         $text =~ s/\$$name(\W|$)/$value$1/g;
  93     } else {
  94         $text =~ s/\${$name:=([^}]*)}/$1/g;
  95         $text =~ s/\${$name}//g;
  96         $text =~ s/\$$name(\W|$)/$1/g;
  97     }
  98     return $text;
  99 }
 100
 101 # option handling helper subs
 102 sub cd_cmd {
 103     my $directory = $_[1];
 104     my $failure   = 1;
 105     if ( -e $directory && -d $directory ) {
 106         chdir("$directory");
 107         print "[Tesh/INFO] change directory to $directory\n";
 108         $failure = 0;
 109     } elsif ( -e $directory ) {
 110         print "Cannot change directory to '$directory': it is not a directory\n";
 111     } else {
 112         print "Chdir to $directory failed: No such file or directory\n";
 113     }
 114     if ( $failure == 1 ) {
 115         print "Test suite `$tesh_file': NOK (system error)\n";
 116         exit 4;
 117     }
 118 }
 119
 120 sub setenv_cmd {
 121     my ( $var, $ctn );
 122     if ( $_[0] =~ /^(.*)=(.*)$/ ) {
 123         ( $var, $ctn ) = ( $1, $2 );
 124     } elsif ( $_[1] =~ /^(.*)=(.*)$/ ) {
 125         ( $var, $ctn ) = ( $1, $2 );
 126     } else {
 127         die "[Tesh/CRITICAL] Malformed argument to setenv: expected 'name=value' but got '$_[1]'\n";
 128     }
 129
 130     print "[Tesh/INFO] setenv $var=$ctn\n";
 131     $environ{$var} = $ctn;
 132 }
 133
 134 # Main option parsing sub
 135
 136 sub get_options {
 137
 138     # remove the tesh file from the ARGV used
 139     my @ARGV = @_;
 140     $tesh_file = pop @ARGV;
 141
 142     # temporary arrays for GetOption
 143     my @cfg;
 144     my $log;    # ignored
 145
 146     my %opt = (
 147         "help"  => 0,
 148         "debug" => 0,
 149     );
 150
 151     Getopt::Long::config( 'bundling', 'no_getopt_compat', 'no_auto_abbrev' );
 152
 153     GetOptions(
 154         'help|h' => \$opt{'help'},
 155
 156         'debug|d' => \$opt{"debug"},
 157
 158         'difftool=s' => \$diff_tool,
 159
 160         'cd=s'             => \&cd_cmd,
 161         'timeout=s'        => \$opt{'timeout'},
 162         'setenv=s'         => \&setenv_cmd,
 163         'cfg=s'            => \@cfg,
 164         'log=s'            => \$log,
 165         'enable-coverage+' => \$enable_coverage,
 166     );
 167
 168     if ($enable_coverage) {
 169         print "Enable coverage\n";
 170     }
 171
 172     if ($diff_tool) {
 173         use File::Temp qw/ tempfile /;
 174         ( $diff_tool_tmp_fh, $diff_tool_tmp_filename ) = tempfile();
 175         print "New tesh: $diff_tool_tmp_filename\n";
 176     }
 177
 178     if ( $tesh_file =~ m/(.*)\.tesh/ ) {
 179         $tesh_name = $1;
 180         print "Test suite `$tesh_name'\n";
 181     } else {
 182         $tesh_file = "(stdin)";
 183         $tesh_name = "(stdin)";
 184         print "Test suite from stdin\n";
 185     }
 186
 187     foreach (@cfg) {
 188         $opt{'cfg'} .= " --cfg=$_";
 189     }
 190     return %opt;
 191 }
 192
 193 my %opts = get_options(@ARGV);
 194
 195 ##
 196 ## File parsing
 197 ##
 198 my ($return) = -1;
 199 my ($forked);
 200 my ($config)      = "";
 201 my (@buffer_tesh) = ();
 202
 203 ###########################################################################
 204
 205 sub exit_status {
 206     my $status = shift;
 207     if ( WIFEXITED($status) ) {
 208         $exitcode = WEXITSTATUS($status) + 40;
 209         return "returned code " . WEXITSTATUS($status);
 210     } elsif ( WIFSIGNALED($status) ) {
 211         my $code;
 212         if    ( WTERMSIG($status) == SIGINT )  { $code = "SIGINT"; }
 213         elsif ( WTERMSIG($status) == SIGTERM ) { $code = "SIGTERM"; }
 214         elsif ( WTERMSIG($status) == SIGKILL ) { $code = "SIGKILL"; }
 215         elsif ( WTERMSIG($status) == SIGABRT ) { $code = "SIGABRT"; }
 216         elsif ( WTERMSIG($status) == SIGSEGV ) { $code = "SIGSEGV"; }
 217         $exitcode = WTERMSIG($status) + 4;
 218         return "got signal $code";
 219     }
 220     return "Unparsable status. Is the process stopped?";
 221 }
 222
 223 sub exec_cmd {
 224     my %cmd = %{ $_[0] };
 225     if ( $opts{'debug'} ) {
 226         print "IN BEGIN\n";
 227         map { print "  $_" } @{ $cmd{'in'} };
 228         print "IN END\n";
 229         print "OUT BEGIN\n";
 230         map { print "  $_" } @{ $cmd{'out'} };
 231         print "OUT END\n";
 232         print "CMD: $cmd{'cmd'}\n";
 233     }
 234
 235     # cleanup the command line
 236     if (RUNNING_ON_WINDOWS) {
 237         var_subst( $cmd{'cmd'}, "EXEEXT", ".exe" );
 238     } else {
 239         var_subst( $cmd{'cmd'}, "EXEEXT", "" );
 240     }
 241
 242     # substitute environ variables
 243     foreach my $key ( keys %environ ) {
 244         $cmd{'cmd'} = var_subst( $cmd{'cmd'}, $key, $environ{$key} );
 245     }
 246
 247     # substitute remaining variables, if any
 248     while ( $cmd{'cmd'} =~ /\${(\w+)(?::[=-][^}]*)?}/ ) {
 249         $cmd{'cmd'} = var_subst( $cmd{'cmd'}, $1, "" );
 250     }
 251     while ( $cmd{'cmd'} =~ /\$(\w+)/ ) {
 252         $cmd{'cmd'} = var_subst( $cmd{'cmd'}, $1, "" );
 253     }
 254
 255     # add cfg options
 256     $cmd{'cmd'} .= " $opts{'cfg'}"
 257       if ( defined( $opts{'cfg'} ) && length( $opts{'cfg'} ) );
 258
 259     # final cleanup
 260     $cmd{'cmd'} =~ s/^\s+//;
 261     $cmd{'cmd'} =~ s/\s+$//;
 262
 263     print "[$tesh_name:$cmd{'line'}] $cmd{'cmd'}\n";
 264
 265     ###
 266     # exec the command line
 267     ###  $line =~ s/\r//g;
 268
 269     $cmd{'got'} = IO::File->new_tmpfile;
 270     $cmd{'got'}->autoflush(1);
 271     local *E = $cmd{'got'};
 272     $cmd{'pid'} =
 273       open3( \*CHILD_IN, ">&E", ">&E", quotewords( '\s+', 0, $cmd{'cmd'} ) );
 274
 275     # push all provided input to executing child
 276     map { print CHILD_IN "$_\n"; } @{ $cmd{'in'} };
 277     close CHILD_IN;
 278
 279     # if timeout specified, fork and kill executing child at the end of timeout
 280     if ( not $cmd{'background'}
 281         and ( defined( $cmd{'timeout'} ) or defined( $opts{'timeout'} ) ) )
 282     {
 283         $time_to_wait =
 284           defined( $cmd{'timeout'} ) ? $cmd{'timeout'} : $opts{'timeout'};
 285         $forked  = fork();
 286         $timeout = -1;
 287         die "fork() failed: $!" unless defined $forked;
 288         if ( $forked == 0 ) {    # child
 289             exec("$PROGRAM_NAME --internal-killer-process $time_to_wait $cmd{'pid'}");
 290         }
 291     }
 292
 293     # Cleanup the executing child, and kill the timeouter brother on need
 294     $cmd{'return'} = 0 unless defined( $cmd{'return'} );
 295     if ( $cmd{'background'} != 1 ) {
 296         waitpid( $cmd{'pid'}, 0 );
 297         $cmd{'gotret'} = exit_status($?);
 298         parse_out( \%cmd );
 299     } else {
 300
 301         # & commands, which will be handled at the end
 302         push @bg_cmds, \%cmd;
 303     }
 304 }
 305
 306 sub parse_out {
 307     my %cmd    = %{ $_[0] };
 308     my $gotret = $cmd{'gotret'};
 309
 310     my $wantret;
 311
 312     if ( defined( $cmd{'expect'} ) and ( $cmd{'expect'} ne "" ) ) {
 313         $wantret = "got signal $cmd{'expect'}";
 314     } else {
 315         $wantret =
 316           "returned code " . ( defined( $cmd{'return'} ) ? $cmd{'return'} : 0 );
 317     }
 318
 319     local *got = $cmd{'got'};
 320     seek( got, 0, 0 );
 321
 322     # pop all output from executing child
 323     my @got;
 324     while ( defined( my $got = <got> ) ) {
 325         $got =~ s/\r//g;
 326         chomp $got;
 327         print $diff_tool_tmp_fh "> $got\n" if ($diff_tool);
 328
 329         if ( !( $enable_coverage and $got =~ /^profiling:/ ) ) {
 330             push @got, $got;
 331         }
 332     }
 333
 334     if ( $cmd{'sort'} ) {
 335
 336         # Save the unsorted observed output to report it on error.
 337         map { push @{ $cmd{'unsorted got'} }, $_ } @got;
 338
 339         sub mysort {
 340             substr( $a, 0, $sort_prefix ) cmp substr( $b, 0, $sort_prefix );
 341         }
 342         use sort 'stable';
 343         if ( $sort_prefix > 0 ) {
 344             @got = sort mysort @got;
 345         } else {
 346             @got = sort @got;
 347         }
 348         while ( @got and $got[0] eq "" ) {
 349             shift @got;
 350         }
 351
 352         # Sort the expected output to make it easier to write for humans
 353         if ( defined( $cmd{'out'} ) ) {
 354             if ( $sort_prefix > 0 ) {
 355                 @{ $cmd{'out'} } = sort mysort @{ $cmd{'out'} };
 356             } else {
 357                 @{ $cmd{'out'} } = sort @{ $cmd{'out'} };
 358             }
 359             while ( @{ $cmd{'out'} } and ${ $cmd{'out'} }[0] eq "" ) {
 360                 shift @{ $cmd{'out'} };
 361             }
 362         }
 363     }
 364
 365     # Did we timeout ? If yes, handle it. If not, kill the forked process.
 366
 367     if ( $timeout == -1
 368         and ( $gotret eq "got signal SIGTERM" or $gotret eq "got signal SIGKILL" ) )
 369     {
 370         $gotret   = "return code 0";
 371         $timeout  = 1;
 372         $gotret   = "timeout after $time_to_wait sec";
 373         $error    = 1;
 374         $exitcode = 3;
 375         print STDERR "<$cmd{'file'}:$cmd{'line'}> timeouted. Kill the process.\n";
 376     } else {
 377         $timeout = 0;
 378     }
 379     if ( $gotret ne $wantret ) {
 380         $error = 1;
 381         my $msg = "Test suite `$cmd{'file'}': NOK (<$cmd{'file'}:$cmd{'line'}> $gotret)\n";
 382         if ( $timeout != 1 ) {
 383             $msg = $msg . "Output of <$cmd{'file'}:$cmd{'line'}> so far:\n";
 384         }
 385         map { $msg .= "|| $_\n" } @got;
 386         if ( !@got ) {
 387             if ( $timeout == 1 ) {
 388                 print STDERR "<$cmd{'file'}:$cmd{'line'}> No output before timeout\n";
 389             } else {
 390                 $msg .= "||\n";
 391             }
 392         }
 393         $timeout = 0;
 394         print STDERR "$msg";
 395     }
 396
 397     ###
 398     # Check the result of execution
 399     ###
 400     my $diff;
 401     if ( defined( $cmd{'output display'} ) ) {
 402         print "[Tesh/INFO] Here is the (ignored) command output:\n";
 403         map { print "||$_\n" } @got;
 404     } elsif ( defined( $cmd{'output ignore'} ) ) {
 405         print "(ignoring the output of <$cmd{'file'}:$cmd{'line'}> as requested)\n";
 406     } else {
 407         $diff = build_diff( \@{ $cmd{'out'} }, \@got );
 408     }
 409     if ( length $diff ) {
 410         print "Output of <$cmd{'file'}:$cmd{'line'}> mismatch" . ( $cmd{'sort'} ? " (even after sorting)" : "" ) . ":\n";
 411         map { print "$_\n" } split( /\n/, $diff );
 412         if ( $cmd{'sort'} ) {
 413             print "WARNING: Both the observed output and expected output were sorted as requested.\n";
 414             print "WARNING: Output were only sorted using the $sort_prefix first chars.\n"
 415               if ( $sort_prefix > 0 );
 416             print "WARNING: Use <! output sort 19> to sort by simulated date and process ID only.\n";
 417
 418             # print "----8<---------------  Begin of unprocessed observed output (as it should appear in file):\n";
 419             # map {print "> $_\n"} @{$cmd{'unsorted got'}};
 420             # print "--------------->8----  End of the unprocessed observed output.\n";
 421         }
 422
 423         print "Test suite `$cmd{'file'}': NOK (<$cmd{'file'}:$cmd{'line'}> output mismatch)\n";
 424         exit 2;
 425     }
 426 }
 427
 428 sub mkfile_cmd {
 429     my %cmd  = %{ $_[0] };
 430     my $file = $cmd{'arg'};
 431     print "[Tesh/INFO] mkfile $file\n";
 432
 433     unlink($file);
 434     open( FILE, ">$file" )
 435       or die "[Tesh/CRITICAL] Unable to create file $file: $!\n";
 436     print FILE join( "\n", @{ $cmd{'in'} } );
 437     print FILE "\n" if ( scalar @{ $cmd{'in'} } > 0 );
 438     close(FILE);
 439 }
 440
 441 # parse tesh file
 442 my $infh;    # The file descriptor from which we should read the teshfile
 443 if ( $tesh_file eq "(stdin)" ) {
 444     $infh = *STDIN;
 445 } else {
 446     open $infh, $tesh_file
 447       or die "[Tesh/CRITICAL] Unable to open $tesh_file: $!\n";
 448 }
 449
 450 my %cmd;     # everything about the next command to run
 451 my $line_num = 0;
 452 LINE: while ( defined( my $line = <$infh> ) and not $error ) {
 453     chomp $line;
 454     $line =~ s/\r//g;
 455
 456     $line_num++;
 457     print "[TESH/debug] $line_num: $line\n" if $opts{'debug'};
 458     my $next;
 459
 460     # deal with line continuations
 461     while ( $line =~ /^(.*?)\\$/ ) {
 462         $next = <$infh>;
 463         die "[TESH/CRITICAL] Continued line at end of file\n"
 464           unless defined($next);
 465         $line_num++;
 466         chomp $next;
 467         print "[TESH/debug] $line_num: $next\n" if $opts{'debug'};
 468         $line = $1 . $next;
 469     }
 470
 471     # Push delayed commands on empty lines
 472     unless ( $line =~ m/^(.)(.*)$/ ) {
 473         if ( defined( $cmd{'cmd'} ) ) {
 474             exec_cmd( \%cmd );
 475             %cmd = ();
 476         }
 477         print $diff_tool_tmp_fh "$line\n" if ($diff_tool);
 478         next LINE;
 479     }
 480
 481     my ( $cmd, $arg ) = ( $1, $2 );
 482     print $diff_tool_tmp_fh "$line\n" if ( $diff_tool and $cmd ne '>' );
 483     $arg =~ s/^ //g;
 484     $arg =~ s/\r//g;
 485     $arg =~ s/\\\\/\\/g;
 486
 487     # handle the commands
 488     if ( $cmd =~ /^#/ ) {    # comment
 489     } elsif ( $cmd eq '>' ) {    # expected result line
 490         print "[TESH/debug] push expected result\n" if $opts{'debug'};
 491         push @{ $cmd{'out'} }, $arg;
 492
 493     } elsif ( $cmd eq '<' ) {    # provided input
 494         print "[TESH/debug] push provided input\n" if $opts{'debug'};
 495         push @{ $cmd{'in'} }, $arg;
 496
 497     } elsif ( $cmd eq 'p' ) {    # comment
 498         print "[$tesh_name:$line_num] $arg\n";
 499
 500     } elsif ( $cmd eq '$' ) {    # Command
 501                                  # if we have something buffered, run it now
 502         if ( defined( $cmd{'cmd'} ) ) {
 503             exec_cmd( \%cmd );
 504             %cmd = ();
 505         }
 506         if ( $arg =~ /^\s*mkfile / ) {    # "mkfile" command line
 507             die "[TESH/CRITICAL] Output expected from mkfile command!\n"
 508               if scalar @{ cmd { 'out' } };
 509
 510             $cmd{'arg'} = $arg;
 511             $cmd{'arg'} =~ s/\s*mkfile //;
 512             mkfile_cmd( \%cmd );
 513             %cmd = ();
 514
 515         } elsif ( $arg =~ /^\s*cd / ) {
 516             die "[TESH/CRITICAL] Input provided to cd command!\n"
 517               if scalar @{ cmd { 'in' } };
 518             die "[TESH/CRITICAL] Output expected from cd command!\n"
 519               if scalar @{ cmd { 'out' } };
 520
 521             $arg =~ s/^ *cd //;
 522             cd_cmd( "", $arg );
 523             %cmd = ();
 524
 525         } else {    # regular command
 526             $cmd{'cmd'}  = $arg;
 527             $cmd{'file'} = $tesh_file;
 528             $cmd{'line'} = $line_num;
 529         }
 530     } elsif ( $cmd eq '&' ) {    # background command line
 531
 532         if ( defined( $cmd{'cmd'} ) ) {
 533             exec_cmd( \%cmd );
 534             %cmd = ();
 535         }
 536         $cmd{'background'} = 1;
 537         $cmd{'cmd'}        = $arg;
 538         $cmd{'file'}       = $tesh_file;
 539         $cmd{'line'}       = $line_num;
 540
 541     } elsif ( $line =~ /^!\s*output sort/ ) {    #output sort
 542         if ( defined( $cmd{'cmd'} ) ) {
 543             exec_cmd( \%cmd );
 544             %cmd = ();
 545         }
 546         $cmd{'sort'} = 1;
 547         if ( $line =~ /^!\s*output sort\s+(\d+)/ ) {
 548             $sort_prefix = $1;
 549         }
 550     } elsif ( $line =~ /^!\s*output ignore/ ) {    #output ignore
 551         if ( defined( $cmd{'cmd'} ) ) {
 552             exec_cmd( \%cmd );
 553             %cmd = ();
 554         }
 555         $cmd{'output ignore'} = 1;
 556     } elsif ( $line =~ /^!\s*output display/ ) {    #output display
 557         if ( defined( $cmd{'cmd'} ) ) {
 558             exec_cmd( \%cmd );
 559             %cmd = ();
 560         }
 561         $cmd{'output display'} = 1;
 562     } elsif ( $line =~ /^!\s*expect signal (\w*)/ ) {    #expect signal SIGABRT
 563         if ( defined( $cmd{'cmd'} ) ) {
 564             exec_cmd( \%cmd );
 565             %cmd = ();
 566         }
 567         print "hey\n";
 568         $cmd{'expect'} = "$1";
 569     } elsif ( $line =~ /^!\s*expect return/ ) {          #expect return
 570         if ( defined( $cmd{'cmd'} ) ) {
 571             exec_cmd( \%cmd );
 572             %cmd = ();
 573         }
 574         $line =~ s/^! expect return //g;
 575         $line =~ s/\r//g;
 576         $cmd{'return'} = $line;
 577     } elsif ( $line =~ /^!\s*setenv/ ) {                 #setenv
 578         if ( defined( $cmd{'cmd'} ) ) {
 579             exec_cmd( \%cmd );
 580             %cmd = ();
 581         }
 582         $line =~ s/^! setenv //g;
 583         $line =~ s/\r//g;
 584         setenv_cmd($line);
 585     } elsif ( $line =~ /^!\s*timeout/ ) {                #timeout
 586         if ( defined( $cmd{'cmd'} ) ) {
 587             exec_cmd( \%cmd );
 588             %cmd = ();
 589         }
 590         $line =~ s/^! timeout //;
 591         $line =~ s/\r//g;
 592         $cmd{'timeout'} = $line;
 593     } else {
 594         die "[TESH/CRITICAL] parse error: $line\n";
 595     }
 596     if ($forked) {
 597         kill( 'KILL', $forked );
 598         $timeout = 0;
 599     }
 600 }
 601
 602 # We're done reading the input file
 603 close $infh unless ( $tesh_file eq "(stdin)" );
 604
 605 # Deal with last command
 606 if ( defined( $cmd{'cmd'} ) ) {
 607     exec_cmd( \%cmd );
 608     %cmd = ();
 609 }
 610
 611 if ($forked) {
 612     kill( 'KILL', $forked );
 613     $timeout = 0;
 614 }
 615
 616 foreach (@bg_cmds) {
 617     my %test = %{$_};
 618     waitpid( $test{'pid'}, 0 );
 619     $test{'gotret'} = exit_status($?);
 620     parse_out( \%test );
 621 }
 622
 623 @bg_cmds = ();
 624
 625 if ($diff_tool) {
 626     close $diff_tool_tmp_fh;
 627     system("$diff_tool $diff_tool_tmp_filename $tesh_file");
 628     unlink $diff_tool_tmp_filename;
 629 }
 630
 631 if ( $error != 0 ) {
 632     exit $exitcode;
 633 } elsif ( $tesh_file eq "(stdin)" ) {
 634     print "Test suite from stdin OK\n";
 635 } else {
 636     print "Test suite `$tesh_name' OK\n";
 637 }
 638
 639 #my (@a,@b);
 640 #push @a,"bl1";   push @b,"bl1";
 641 #push @a,"bl2";   push @b,"bl2";
 642 #push @a,"bl3";   push @b,"bl3";
 643 #push @a,"bl4";   push @b,"bl4";
 644 #push @a,"bl5";   push @b,"bl5";
 645 #push @a,"bl6";   push @b,"bl6";
 646 #push @a,"bl7";   push @b,"bl7";
 647 ##push @a,"Perl";  push @b,"ruby";
 648 #push @a,"END1";   push @b,"END1";
 649 #push @a,"END2";   push @b,"END2";
 650 #push @a,"END3";   push @b,"END3";
 651 #push @a,"END4";   push @b,"END4";
 652 #push @a,"END5";   push @b,"END5";
 653 #push @a,"END6";   push @b,"END6";
 654 #push @a,"END7";   push @b,"END7";
 655 #print "Identical:\n". build_diff(\@a,\@b);
 656
 657 #@a = (); @b =();
 658 #push @a,"AZE"; push @b,"EZA";
 659 #print "Different:\n".build_diff(\@a,\@b);
 660
 661 use lib "@CMAKE_BINARY_DIR@/bin";
 662
 663 use Diff qw(diff);    # postpone a bit to have time to change INC
 664
 665 sub build_diff {
 666     my $res;
 667     my $diff = Diff->new(@_);
 668
 669     $diff->Base(1);    # Return line numbers, not indices
 670     my $chunk_count = $diff->Next(-1);    # Compute the amount of chuncks
 671     return "" if ( $chunk_count == 1 && $diff->Same() );
 672     $diff->Reset();
 673     while ( $diff->Next() ) {
 674         my @same = $diff->Same();
 675         if ( $diff->Same() ) {
 676             if ( $diff->Next(0) > 1 ) {    # not first chunk: print 2 first lines
 677                 $res .= '  ' . $same[0] . "\n";
 678                 $res .= '  ' . $same[1] . "\n" if ( scalar @same > 1 );
 679             }
 680             $res .= "...\n" if ( scalar @same > 2 );
 681
 682             #    $res .= $diff->Next(0)."/$chunk_count\n";
 683             if ( $diff->Next(0) < $chunk_count ) {    # not last chunk: print 2 last lines
 684                 $res .= '  ' . $same[ scalar @same - 2 ] . "\n"
 685                   if ( scalar @same > 1 );
 686                 $res .= '  ' . $same[ scalar @same - 1 ] . "\n";
 687             }
 688         }
 689         next if $diff->Same();
 690         map { $res .= "- $_\n" } $diff->Items(1);
 691         map { $res .= "+ $_\n" } $diff->Items(2);
 692     }
 693     return $res;
 694 }
 695