#!/usr/bin/env perl # -*-perl-*- # # This script helps us write tests in a portable way, without relying on a lot # of shell features. Since we already have Perl to run the tests, use that. # # The arguments represent a set of steps that will be run one at a time. # Each step consists of an operator and argument. # # It supports the following operators: # out : echo to stdout # file : echo to stdout AND create the file # dir : echo to stdout AND create the directory # rm : echo to stdout AND delete the file/directory # wait : wait for a file named to exist # tmout : Change the timeout for waiting. Default is 4 seconds. # sleep : Sleep for seconds then echo # fail : echo to stdout then exit with error code err # # If given -q only the "out" command generates output. # Force flush $| = 1; my $quiet = 0; my $timeout = 4; sub op { my ($op, $nm) = @_; defined $nm or die "Missing value for $op\n"; if ($op eq 'out') { print "$nm\n"; return 1; } # Show the output before creating the file if ($op eq 'file') { print "file $nm\n" unless $quiet; open(my $fh, '>', $nm) or die "$nm: open: $!\n"; close(my $fh); return 1; } # Show the output before creating the directory if ($op eq 'dir') { print "dir $nm\n" unless $quiet; mkdir($nm) or die "$nm: mkdir: $!\n"; return 1; } # Show the output after removing the file if ($op eq 'rm') { if (-f $nm) { unlink($nm) or die "$nm: unlink: $!\n"; } elsif (-d $nm) { rmdir($nm) or die "$nm: rmdir: $!\n"; } else { die "$nm: not file or directory: $!\n"; } print "rm $nm\n" unless $quiet; return 1; } if ($op eq 'tmout') { $timeout = $nm; print "tmout $nm\n" unless $quiet; return 1; } # Show the output after the file exists if ($op eq 'wait') { my $start = time(); my $end = $start + $timeout; while (time() <= $end) { if (-f $nm) { print "wait $nm\n" unless $quiet; return 1; } select(undef, undef, undef, 0.1); } die "wait $nm: timeout after ".(time()-$start-1)." seconds\n"; } # Show the output after sleeping if ($op eq 'sleep') { sleep($nm); print "sleep $nm\n" unless $quiet; return 1; } if ($op eq 'fail') { print "fail $nm\n"; exit($nm); } die("Invalid command: $op $nm\n"); } if (@ARGV && $ARGV[0] eq '-q') { $quiet = 1; shift; } while (@ARGV) { if (op($ARGV[0], $ARGV[1])) { shift; shift; } } exit(0);