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