chdir 't' if -d 't';
@INC = '../lib';
require Config; import Config;
- unless ($Config{'d_fork'}) {
- print "1..0 # Skip: no fork\n";
- exit 0;
+ require './test.pl';
+
+ if (!$Config{'d_fork'}) {
+ skip_all("fork required to pipe");
+ }
+ else {
+ plan(tests => 22);
}
}
+my $Perl = which_perl();
+
+
$| = 1;
-print "1..16\n";
-# External program 'tr' assumed.
-open(PIPE, "|-") || (exec 'tr', 'YX', 'ko');
-print PIPE "Xk 1\n";
-print PIPE "oY 2\n";
+open(PIPE, "|-") || exec $Perl, '-pe', 'tr/YX/ko/';
+
+printf PIPE "Xk %d - open |- || exec\n", curr_test();
+next_test();
+printf PIPE "oY %d - again\n", curr_test();
+next_test();
close PIPE;
-if ($^O eq 'vmesa') {
- # Doesn't work, yet.
- for (3..6) {
- print "ok $_ # skipped\n";
- }
-} else {
+SKIP: {
+ # Technically this should be TODO. Someone try it if you happen to
+ # have a vmesa machine.
+ skip "Doesn't work here yet", 4 if $^O eq 'vmesa';
+
if (open(PIPE, "-|")) {
while(<PIPE>) {
s/^not //;
print;
}
- close PIPE; # avoid zombies which disrupt test 12
+ close PIPE; # avoid zombies
}
else {
- # External program 'echo' assumed.
- print STDOUT "not ok 3\n";
- exec 'echo', 'not ok 4';
+ printf STDOUT "not ok %d - open -|\n", curr_test();
+ next_test();
+ my $tnum = curr_test;
+ next_test();
+ exec $Perl, '-le', "print q{not ok $tnum - again}";
}
- pipe(READER,WRITER) || die "Can't open pipe";
-
- if ($pid = fork) {
- close WRITER;
- while(<READER>) {
- s/^not //;
- y/A-Z/a-z/;
- print;
- }
- close READER; # avoid zombies which disrupt test 12
- }
- else {
- die "Couldn't fork" unless defined $pid;
- close READER;
- print WRITER "not ok 5\n";
- open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
- close WRITER;
- # External program 'echo' assumed.
- exec 'echo', 'not ok 6';
+ # This has to be *outside* the fork
+ next_test() for 1..2;
+
+ SKIP: {
+ skip "fork required", 2 unless $Config{d_fork};
+
+ pipe(READER,WRITER) || die "Can't open pipe";
+
+ if ($pid = fork) {
+ close WRITER;
+ while(<READER>) {
+ s/^not //;
+ y/A-Z/a-z/;
+ print;
+ }
+ close READER; # avoid zombies
+ }
+ else {
+ die "Couldn't fork" unless defined $pid;
+ close READER;
+ printf WRITER "not ok %d - pipe & fork\n", curr_test;
+ next_test;
+
+ open(STDOUT,">&WRITER") || die "Can't dup WRITER to STDOUT";
+ close WRITER;
+
+ my $tnum = curr_test;
+ next_test;
+ exec $Perl, '-le', "print q{not ok $tnum - with fh dup }";
+ }
+
+ # This has to be done *outside* the fork.
+ next_test() for 1..2;
}
-}
+}
wait; # Collect from $pid
pipe(READER,WRITER) || die "Can't open pipe";
sub broken_pipe {
$SIG{'PIPE'} = 'IGNORE'; # loop preventer
- print "ok 7\n";
+ printf "ok %d - SIGPIPE\n", curr_test;
}
-print WRITER "not ok 7\n";
+printf WRITER "not ok %d - SIGPIPE\n", curr_test;
close WRITER;
sleep 1;
-print "ok 8\n";
+next_test;
+pass();
# VMS doesn't like spawning subprocesses that are still connected to
-# STDOUT. Someone should modify tests #9 to #12 to work with VMS.
-
-if ($^O eq 'VMS') {
- print "ok 9 # skipped\n";
- print "ok 10 # skipped\n";
- print "ok 11 # skipped\n";
- print "ok 12 # skipped\n";
- exit;
-}
-
-if ($Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' || $^O eq 'posix-bc') {
- # Sfio doesn't report failure when closing a broken pipe
- # that has pending output. Go figure. MachTen doesn't either,
- # but won't write to broken pipes, so nothing's pending at close.
- # BeOS will not write to broken pipes, either.
- # Nor does POSIX-BC.
- print "ok 9 # skipped\n";
-}
-else {
- local $SIG{PIPE} = 'IGNORE';
- open NIL, '|true' or die "open failed: $!";
- sleep 5;
- if (print NIL 'foo') {
- # If print was allowed we had better get an error on close
- if (close NIL) {
- print "not ok 9\n";
- }
- else {
- print "ok 9\n";
- }
- }
- else {
- # If print failed, the close should be clean
- if (close NIL) {
- print "ok 9\n";
- }
- else {
- print "not ok 9\n";
- }
+# STDOUT. Someone should modify these tests to work with VMS.
+
+SKIP: {
+ skip "doesn't like spawning subprocesses that are still connected", 10
+ if $^O eq 'VMS';
+
+ SKIP: {
+ # Sfio doesn't report failure when closing a broken pipe
+ # that has pending output. Go figure. MachTen doesn't either,
+ # but won't write to broken pipes, so nothing's pending at close.
+ # BeOS will not write to broken pipes, either.
+ # Nor does POSIX-BC.
+ skip "Won't report failure on broken pipe", 1
+ if $Config{d_sfio} || $^O eq 'machten' || $^O eq 'beos' ||
+ $^O eq 'posix-bc';
+
+ local $SIG{PIPE} = 'IGNORE';
+ open NIL, qq{|$Perl -e "exit 0"} or die "open failed: $!";
+ sleep 5;
+ if (print NIL 'foo') {
+ # If print was allowed we had better get an error on close
+ ok( !close NIL, 'close error on broken pipe' );
+ }
+ else {
+ ok(close NIL, 'print failed on broken pipe');
+ }
}
-}
-if ($^O eq 'vmesa') {
- # These don't work, yet.
- print "ok 10 # skipped\n";
- print "ok 11 # skipped\n";
- print "ok 12 # skipped\n";
- exit;
-}
-
-# check that errno gets forced to 0 if the piped program exited non-zero
-open NIL, '|exit 23;' or die "fork failed: $!";
-$! = 1;
-if (close NIL) {
- print "not ok 10\n# successful close\n";
-}
-elsif ($! != 0) {
- print "not ok 10\n# errno $!\n";
-}
-elsif ($? == 0) {
- print "not ok 10\n# status 0\n";
-}
-else {
- print "ok 10\n";
-}
-
-if ($^O eq 'mpeix') {
- print "ok 11 # skipped\n";
- print "ok 12 # skipped\n";
-} else {
- # check that status for the correct process is collected
- my $zombie = fork or exit 37;
- my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
- $SIG{ALRM} = sub { return };
- alarm(1);
- my $close = close FH;
- if ($? == 13*256 && ! length $close && ! $!) {
- print "ok 11\n";
- } else {
- print "not ok 11\n# close $close\$?=$? \$!=", $!+0, ":$!\n";
- };
- my $wait = wait;
- if ($? == 37*256 && $wait == $zombie && ! $!) {
- print "ok 12\n";
- } else {
- print "not ok 12\n# pid=$wait first=$pid pipe=$pipe zombie=$zombie me=$$ \$?=$? \$!=", $!+0, ":$!\n";
+ SKIP: {
+ skip "Don't work yet", 9 if $^O eq 'vmesa';
+
+ # check that errno gets forced to 0 if the piped program exited
+ # non-zero
+ open NIL, qq{|$Perl -e "exit 23";} or die "fork failed: $!";
+ $! = 1;
+ ok(!close NIL, 'close failure on non-zero piped exit');
+ is($!, '', ' errno');
+ isnt($?, 0, ' status');
+
+ SKIP: {
+ skip "Don't work yet", 6 if $^O eq 'mpeix';
+
+ # check that status for the correct process is collected
+ my $zombie;
+ unless( $zombie = fork ) {
+ $NO_ENDING=1;
+ exit 37;
+ }
+ my $pipe = open *FH, "sleep 2;exit 13|" or die "Open: $!\n";
+ $SIG{ALRM} = sub { return };
+ alarm(1);
+ is( close FH, '', 'close failure for... umm, something' );
+ is( $?, 13*256, ' status' );
+ is( $!, '', ' errno');
+
+ my $wait = wait;
+ is( $?, 37*256, 'status correct after wait' );
+ is( $wait, $zombie, ' wait pid' );
+ is( $!, '', ' errno');
+ }
}
}
# Test new semantics for missing command in piped open
# 19990114 M-J. Dominus mjd@plover.com
{ local *P;
- print (((open P, "| " ) ? "not " : ""), "ok 13\n");
- print (((open P, " |" ) ? "not " : ""), "ok 14\n");
+ ok( !open(P, "| "), 'missing command in piped open input' );
+ ok( !open(P, " |"), ' output');
}
# check that status is unaffected by implicit close
{
local(*NIL);
- open NIL, '|exit 23;' or die "fork failed: $!";
+ open NIL, qq{|$Perl -e "exit 23"} or die "fork failed: $!";
$? = 42;
# NIL implicitly closed here
}
-if ($? != 42) {
- print "# status $?, expected 42\nnot ";
-}
-print "ok 15\n";
+is($?, 42, 'status unaffected by implicit close');
$? = 0;
# check that child is reaped if the piped program can't be executed
alarm 0;
};
- print "not " if $child != -1;
- print "ok 16\n";
+ is($child, -1, 'child reaped if piped program cannot be executed');
}
$ENV{LC_ALL} = 'C'; # Forge English error messages.
$ENV{LANGUAGE} = 'C'; # Ditto in GNU.
-plan(tests => 14);
+my $Is_VMS = $^O eq 'VMS';
+
+plan(tests => 20);
my $Perl = which_perl();
SKIP: {
skip("bug/feature of pdksh", 2) if $^O eq 'os2';
- $exit = system qq{$Perl -le "print q{ok 1 - interpreted system(EXPR)"}};
+ my $tnum = curr_test();
+ $exit = system qq{$Perl -le "print q{ok $tnum - interp system(EXPR)"}};
next_test();
is( $exit, 0, ' exited 0' );
}
-$exit = system qq{$Perl -le "print q{ok 3 - split & direct call system(EXPR)"}};
+my $tnum = curr_test();
+$exit = system qq{$Perl -le "print q{ok $tnum - split & direct system(EXPR)"}};
next_test();
is( $exit, 0, ' exited 0' );
# On VMS you need the quotes around the program or it won't work.
# On Unix its the opposite.
-my $quote = $^O eq 'VMS' ? '"' : '';
+my $quote = $Is_VMS ? '"' : '';
+$tnum = curr_test();
$exit = system $Perl, '-le',
- "${quote}print q{ok 5 - system(PROG, LIST)}${quote}";
+ "${quote}print q{ok $tnum - system(PROG, LIST)}${quote}";
next_test();
is( $exit, 0, ' exited 0' );
+# Some basic piped commands. Some OS's have trouble with "helpfully"
+# putting newlines on the end of piped output. So we split this into
+# newline insensitive and newline sensitive tests.
+my $echo_out = `$Perl -e "print 'ok'" | $Perl -le "print <STDIN>"`;
+$echo_out =~ s/\n\n/\n/g;
+is( $echo_out, "ok\n", 'piped echo emulation');
+
+{
+ # here we check if extra newlines are going to be slapped on
+ # piped output.
+ local $TODO = 'VMS sticks newlines on everything' if $Is_VMS;
+
+ is( scalar `$Perl -e "print 'ok'"`,
+ "ok", 'no extra newlines on ``' );
+
+ is( scalar `$Perl -e "print 'ok'" | $Perl -e "print <STDIN>"`,
+ "ok", 'no extra newlines on pipes');
+
+ is( scalar `$Perl -le "print 'ok'" | $Perl -le "print <STDIN>"`,
+ "ok\n\n", 'doubled up newlines');
+
+ is( scalar `$Perl -e "print 'ok'" | $Perl -le "print <STDIN>"`,
+ "ok\n", 'extra newlines on inside pipes');
+
+ is( scalar `$Perl -le "print 'ok'" | $Perl -e "print <STDIN>"`,
+ "ok\n", 'extra newlines on outgoing pipes');
+}
+
+
is( system(qq{$Perl -e "exit 0"}), 0, 'Explicit exit of 0' );
-my $exit_one = $^O eq 'VMS' ? 4 << 8 : 1 << 8;
+my $exit_one = $Is_VMS ? 4 << 8 : 1 << 8;
is( system(qq{$Perl "-I../lib" -e "use vmsish qw(hushed); exit 1"}), $exit_one,
'Explicit exit of 1' );
TODO: {
+ my $tnum = curr_test();
if( $^O =~ /Win32/ ) {
- print "not ok 11 - exec failure doesn't terminate process # TODO Win32 exec failure waits for user input\n";
+ print "not ok $tnum - exec failure doesn't terminate process # TODO Win32 exec failure waits for user input\n";
+ next_test;
last TODO;
}
$ If F$Search("VMSPIPE.COM").nes."" then Delete/Log/Noconfirm VMSPIPE.COM;*
$ Copy/Log/NoConfirm [-]VMSPIPE.COM []
$!
-$! Make the environment look a little friendlier to tests which assume Unix
-$ cat == "Type"
-$ Macro/NoDebug/NoList/Object=Echo.Obj Sys$Input
- .title echo
- .psect data,wrt,noexe
- dsc:
- .word 0
- .byte 14 ; DSC$K_DTYPE_T
- .byte 2 ; DSC$K_CLASS_D
- .long 0
- .psect code,nowrt,exe
- .entry echo,^m<r2,r3>
- movab dsc,r2
- pushab (r2)
- calls #1,G^LIB$GET_FOREIGN
- movl 4(r2),r3
- movzwl (r2),r0
- addl2 4(r2),r0
- cmpl r3,r0
- bgtru sym.3
- nop
- sym.1:
- movb (r3),r0
- cmpb r0,#65
- blss sym.2
- cmpb r0,#90
- bgtr sym.2
- cvtbl r0,r0
- addl2 #32,r0
- cvtlb r0,(r3)
- sym.2:
- incl r3
- movzwl (r2),r0
- addl2 4(r2),r0
- cmpl r3,r0
- blequ sym.1
- sym.3:
- pushab (r2)
- calls #1,G^LIB$PUT_OUTPUT
- movl #1,r0
- ret
- .end echo
-$ If F$Search("Echo.Exe").nes."" Then Delete/Log/NoConfirm Echo.Exe;*
-$ Link/NoMap/NoTrace/Exe=Echo.Exe Echo.Obj;
-$ Delete/Log/NoConfirm Echo.Obj;*
-$ echo == "$" + F$Parse("Echo.Exe")
-$!
$! And do it
$ Show Process/Accounting
$ testdir = "Directory/NoHead/NoTrail/Column=1"
$ PerlShr_filespec = f$parse("Sys$Disk:[-]''dbg'PerlShr''exe'")
$ Define 'dbg'Perlshr 'PerlShr_filespec'
+$ if f$mode() .nes. "INTERACTIVE" then Define PERL_SKIP_TTY_TEST 1
$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'"
$ Deck/Dollar=$$END-OF-TEST$$
-# $RCSfile: test.com,v $$Revision: 1.1 $$Date: 2001/12/05 06:53:37 $
-# Modified for VMS 30-Sep-1994 Charles Bailey bailey@newman.upenn.edu
#
-# This is written in a peculiar style, since we're trying to avoid
-# most of the constructs we'll be testing for.
+# The bulk of the below code is scheduled for deletion. test.com
+# will shortly use t/TEST.
+#
-# skip those tests we know will fail entirely or cause perl to hang bacause
-# of Unixisms in the tests. (The Perl operators being tested may work fine,
-# but the tests may use other operators which don't.)
use Config;
use File::Spec;
projects / p5sagit/p5-mst-13.2.git / commitdiff