1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 @INC = '../lib'; 6} 7 8my $Invoke_Perl = qq(MCR $^X "-I[-.lib]"); 9 10require "./test.pl"; 11plan(tests => 25); 12 13SKIP: { 14 skip("tests for non-VMS only", 1) if $^O eq 'VMS'; 15 16 no utf8; 17 18 BEGIN { $Orig_Bits = $^H } 19 20 # make sure that all those 'use vmsish' calls didn't do anything. 21 is( $Orig_Bits, $^H, 'use vmsish a no-op' ); 22} 23 24SKIP: { 25 skip("tests for VMS only", 24) unless $^O eq 'VMS'; 26 27#========== vmsish status ========== 28`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter. 29is($?,0,"simple Perl invokation: POSIX success status"); 30{ 31 use vmsish qw(status); 32 is(($? & 1),1, "importing vmsish [vmsish status]"); 33 { 34 no vmsish qw(status); # check unimport function 35 is($?,0, "unimport vmsish [POSIX STATUS]"); 36 } 37 # and lexical scoping 38 is(($? & 1),1,"lex scope of vmsish [vmsish status]"); 39} 40is($?,0,"outer lex scope of vmsish [POSIX status]"); 41 42{ 43 use vmsish qw(exit); # check import function 44 is($?,0,"importing vmsish exit [POSIX status]"); 45} 46 47#========== vmsish exit, messages ========== 48{ 49 use vmsish qw(status); 50 51 $msg = do_a_perl('-e "exit 1"'); 52 $msg =~ s/\n/\\n/g; # keep output on one line 53 like($msg,'ABORT', "POSIX ERR exit, DCL error message check"); 54 is($?&1,0,"vmsish status check, POSIX ERR exit"); 55 56 $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"'); 57 $msg =~ s/\n/\\n/g; # keep output on one line 58 ok(length($msg)==0,"vmsish OK exit, DCL error message check"); 59 is($?&1,1, "vmsish status check, vmsish OK exit"); 60 61 $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"'); 62 $msg =~ s/\n/\\n/g; # keep output on one line 63 like($msg, 'ABORT', "vmsish ERR exit, DCL error message check"); 64 is($?&1,0,"vmsish ERR exit, vmsish status check"); 65 66 $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"'); 67 $msg =~ s/\n/\\n/g; # keep output on one line 68 ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check"); 69 70 $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"'); 71 $msg =~ s/\n/\\n/g; # keep output on one line 72 ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check"); 73 74 $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"'); 75 $msg =~ s/\n/\\n/g; # keep output on one line 76 like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check"); 77 78 $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"'); 79 $msg =~ s/\n/\\n/g; # keep output on one line 80 ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check"); 81 82 $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"'); 83 $msg =~ s/\n/\\n/g; # keep output on one line 84 ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check"); 85 86 $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"'); 87 $msg =~ s/\n/\\n/g; # keep output on one line 88 ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check"); 89 90 local *TEST; 91 open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing'); 92 print TEST "#! perl\n"; 93 print TEST "use vmsish qw(hushed);\n"; 94 print TEST "\$obvious = (\$compile(\$error;\n"; 95 close TEST; 96 $msg = do_a_perl('vmsish_test.pl'); 97 $msg =~ s/\n/\\n/g; # keep output on one line 98 ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check"); 99 unlink 'vmsish_test.pl'; 100} 101 102 103#========== vmsish time ========== 104{ 105 my($utctime, @utclocal, @utcgmtime, $utcmtime, 106 $vmstime, @vmslocal, @vmsgmtime, $vmsmtime, 107 $utcval, $vmaval, $offset); 108 # Make sure apparent local time isn't GMT 109 if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) { 110 $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; 111 $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600; 112 eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }"; 113 gmtime(0); # Force reset of tz offset 114 } 115 { 116 use_ok('vmsish qw(time)'); 117 $vmstime = time; 118 @vmslocal = localtime($vmstime); 119 @vmsgmtime = gmtime($vmstime); 120 $vmsmtime = (stat $0)[9]; 121 } 122 $utctime = time; 123 @utclocal = localtime($vmstime); 124 @utcgmtime = gmtime($vmstime); 125 $utcmtime = (stat $0)[9]; 126 127 $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; 128 129 # We allow lots of leeway (10 sec) difference for these tests, 130 # since it's unlikely local time will differ from UTC by so small 131 # an amount, and it renders the test resistant to delays from 132 # things like stat() on a file mounted over a slow network link. 133 ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime"); 134 135 $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 + 136 $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; 137 $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + 138 $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; 139 ok($vmsval - $utcval + $offset <= 10, "(localtime)"); 140 print "# UTC: @utclocal\n# VMS: @vmslocal\n"; 141 142 $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + 143 $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; 144 $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + 145 $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; 146 ok($vmsval - $utcval + $offset <= 10, "(gmtime)"); 147 print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; 148 149 ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime"); 150} 151} 152 153#====== need this to make sure error messages come out, even if 154# they were turned off in invoking procedure 155sub do_a_perl { 156 local *P; 157 open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); 158 print P "\$ set message/facil/sever/ident/text\n"; 159 print P "\$ define/nolog/user sys\$error _nla0:\n"; 160 print P "\$ $Invoke_Perl @_\n"; 161 close P; 162 my $x = `\@vmsish_test.com`; 163 unlink 'vmsish_test.com'; 164 return $x; 165} 166 167