| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 4 | chdir 't' if -d 't'; |
| 5 | @INC = '../lib'; |
| 6 | } |
| 7 | |
| 8 | my $perl = $^X; |
| 9 | $perl = VMS::Filespec::vmsify($perl) if $^O eq 'VMS'; |
| 10 | |
| 11 | my $Invoke_Perl = qq(MCR $perl "-I[-.lib]"); |
| 12 | |
| 13 | use Test::More tests => 29; |
| 14 | |
| 15 | SKIP: { |
| 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 | |
| 26 | SKIP: { |
| 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. |
| 31 | is($?,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 | } |
| 42 | is($?,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 | |
| 186 | #====== need this to make sure error messages come out, even if |
| 187 | # they were turned off in invoking procedure |
| 188 | sub do_a_perl { |
| 189 | local *P; |
| 190 | open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); |
| 191 | print P "\$ set message/facil/sever/ident/text\n"; |
| 192 | print P "\$ define/nolog/user sys\$error _nla0:\n"; |
| 193 | print P "\$ $Invoke_Perl @_\n"; |
| 194 | close P; |
| 195 | my $x = `\@vmsish_test.com`; |
| 196 | unlink 'vmsish_test.com'; |
| 197 | return $x; |
| 198 | } |
| 199 | |