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