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