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