From b6345914e6a5bcc0fcf2c030fb88a31b5c80a120 Mon Sep 17 00:00:00 2001 From: Jarkko Hietaniemi Date: Sat, 8 Dec 2001 15:29:18 +0000 Subject: [PATCH] [PATCH lib/vmsish.t] Small test name abuse. From: Michael G Schwern Date: Fri, 7 Dec 2001 20:03:45 -0500 Message-ID: <20011208010345.GD642@blackrider> Subject: [PATCH vms/test.com] Goodbye frightening echo kludge! From: Michael G Schwern Date: Fri, 7 Dec 2001 20:13:54 -0500 Message-ID: <20011208011354.GE642@blackrider> Subject: [PATCH t/io/pipe.t t/test.pl] Cleanup & $NO_ENDING From: Michael G Schwern Date: Fri, 7 Dec 2001 21:47:36 -0500 Message-ID: <20011208024736.GH642@blackrider> Subject: [PATCH t/op/exec.t] Piping and newline on pipe tests From: Michael G Schwern Date: Fri, 7 Dec 2001 23:09:43 -0500 Message-ID: <20011208040943.GK642@blackrider> Subject: [PATCH] vms/test.com -- skip tty tests when not interactive Message-Id: Date: Fri, 7 Dec 2001 23:28:15 -0600 From: "Craig A. Berry" p4raw-id: //depot/perl@13535 --- lib/vmsish.t | 6 +- t/io/pipe.t | 262 +++++++++++++++++++++++++++++------------------------------ t/op/exec.t | 50 ++++++++++-- t/test.pl | 5 +- vms/test.com | 58 +------------ 5 files changed, 182 insertions(+), 199 deletions(-) diff --git a/lib/vmsish.t b/lib/vmsish.t index 2d83be6..03fdd60 100644 --- a/lib/vmsish.t +++ b/lib/vmsish.t @@ -134,13 +134,15 @@ is($?,0,"outer lex scope of vmsish [POSIX status]"); $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; - ok($vmsval - $utcval + $offset <= 10, "(localtime)\n# UTC: @utclocal\n# VMS: @vmslocal"); + ok($vmsval - $utcval + $offset <= 10, "(localtime)"); + print "# UTC: @utclocal\n# VMS: @vmslocal\n"; $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; - ok($vmsval - $utcval + $offset <= 10, "(gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime"); + ok($vmsval - $utcval + $offset <= 10, "(gmtime)"); + print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime"); } diff --git a/t/io/pipe.t b/t/io/pipe.t index 5008325..c32f3b1 100755 --- a/t/io/pipe.t +++ b/t/io/pipe.t @@ -4,61 +4,84 @@ BEGIN { 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() { 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() { - 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() { + 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"; @@ -68,122 +91,94 @@ $SIG{'PIPE'} = 'broken_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 @@ -199,6 +194,5 @@ $? = 0; alarm 0; }; - print "not " if $child != -1; - print "ok 16\n"; + is($child, -1, 'child reaped if piped program cannot be executed'); } diff --git a/t/op/exec.t b/t/op/exec.t index 1be58fe..271570f 100755 --- a/t/op/exec.t +++ b/t/op/exec.t @@ -14,7 +14,9 @@ $| = 1; # flush stdout $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(); @@ -22,27 +24,59 @@ my $exit; 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 "`; +$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 "`, + "ok", 'no extra newlines on pipes'); + + is( scalar `$Perl -le "print 'ok'" | $Perl -le "print "`, + "ok\n\n", 'doubled up newlines'); + + is( scalar `$Perl -e "print 'ok'" | $Perl -le "print "`, + "ok\n", 'extra newlines on inside pipes'); + + is( scalar `$Perl -le "print 'ok'" | $Perl -e "print "`, + "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' ); @@ -66,8 +100,10 @@ END 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; } diff --git a/t/test.pl b/t/test.pl index c5259de..fc39591 100644 --- a/t/test.pl +++ b/t/test.pl @@ -6,6 +6,7 @@ my $test = 1; my $planned; $TODO = 0; +$NO_ENDING = 0; sub plan { my $n; @@ -21,8 +22,8 @@ sub plan { END { my $ran = $test - 1; - if (defined $planned && $planned != $ran) { - print STDOUT "# Looks like you planned $planned tests but ran $ran.\n"; + if (!$NO_ENDING && defined $planned && $planned != $ran) { + print STDOUT "# Looks like you planned $planned tests but ran $ran.\n"; } } diff --git a/vms/test.com b/vms/test.com index 7c2174f..8c4d840 100644 --- a/vms/test.com +++ b/vms/test.com @@ -48,69 +48,19 @@ $! Pick up a copy of vmspipe.com to use for the tests $ 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 - 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; -- 2.7.4