#! perl # $^X external-command.pl [options] # # We don't know what OS and environment we are testing on. # The only external program we can be confident about having # is perl, so when an external program is needed to test # something, we'll use a perl script. # # Depending on the command line arguments provided, this script # is capable of mocking an external command by running for a certain # amount of time, producing simple output to a file, determining # environment like the PPID, and exiting with an arbitrary exit code. # # -s=n go to sleep for seconds # -e=msg writes the msg to standard output or output # -o=file redirect standard output to file # -p outputs the parent PID # -x=z exit with code # -y=n print line from STDIN times to STDOUT, once to STDERR # # # Examples: # # $^X t/external-command.pl -o=t/out/test -e=Hello, -e=Whirled -p -x=0 # # This script is used in tests: # t/11-to-command.t # t/13-to-exec.t # t/40-timeout.t # t/42-filehandle.t # t/45-userbusy.t # t/60-os.t # t/63-bg_qx.t # use strict; use warnings; no warnings; my $flag_on_error = 0; my $STATUS=0; #$SIG{'INT'} = sub { $STATUS=2; die $^O eq 'MSWin32' ? "die INT\n" : "\n";}; $SIG{'HUP'} = sub { $STATUS=1; die $^O eq 'MSWin32' ? "die HUP\n" : "\n";}; END { $?=$STATUS if $STATUS; if ($flag_on_error) { print STDERR "FLAG $?\n"; } print OUT "\n"; print STDOUT "\n"; close OUT; close STDOUT; close STDERR; 1; } $| = 1; foreach my $arg (@ARGV) { my ($key,$val) = split /=/, $arg; if ($key eq '--output' or $key eq '-o') { open(OUT, '>', $val); select OUT; $| = 1; } elsif ($key eq '--echo' or $key eq '-e') { print $val, ' '; } elsif ($key eq '--ppid' or $key eq '-p') { # On MSWin32, getppid() is broken. my $ppid = $^O eq 'MSWin32' ? $ENV{_FORK_PPID} : getppid(); print $ppid, ' '; } elsif ($key eq '--pid' or $key eq '-P') { my $pid = $^O eq 'MSWin32' ? $ENV{_FORK_PID} : $$; print $pid, ' '; } elsif ($key eq '--winpid' or $key eq '-W') { print $$, ' '; } elsif ($key eq '--sleep' or $key eq '-s') { sleep $val || 1; } elsif ($key eq '--exit' or $key eq '-x') { $flag_on_error = 0; exit $val || 0; } elsif ($key eq '--input' or $key eq '-y') { my $y = ; while ($val-- > 0) { print $y; } print STDERR "received message $y"; } elsif ($key eq '--newline' or $key eq '-n') { print "\n"; } elsif ($key eq '--flag' or $key eq '-F') { $flag_on_error = 1; } } $flag_on_error = 0; exit 0;