summaryrefslogtreecommitdiff
path: root/vms/ext/vmsish.t
diff options
context:
space:
mode:
Diffstat (limited to 'vms/ext/vmsish.t')
-rw-r--r--vms/ext/vmsish.t107
1 files changed, 53 insertions, 54 deletions
diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t
index d63da57235..0f3c0ec1eb 100644
--- a/vms/ext/vmsish.t
+++ b/vms/ext/vmsish.t
@@ -3,31 +3,27 @@ BEGIN { unshift @INC, '[-.lib]'; }
my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
-print "1..17\n";
+require "test.pl";
+plan(tests => 24);
#========== vmsish status ==========
`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
-if ($?) { print "not ok 1 # POSIX status is $?\n"; }
-else { print "ok 1\n"; }
+is($?,0,"simple Perl invokation: POSIX success status");
{
use vmsish qw(status);
- if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; }
- else { print "ok 2\n"; }
+ is(($? & 1),1, "importing vmsish [vmsish status]");
{
- no vmsish '$?'; # check unimport function
- if ($?) { print "not ok 3 # POSIX status is $?\n"; }
- else { print "ok 3\n"; }
+ no vmsish qw(status); # check unimport function
+ is($?,0, "unimport vmsish [POSIX STATUS]");
}
# and lexical scoping
- if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; }
- else { print "ok 4\n"; }
+ is(($? & 1),1,"lex scope of vmsish [vmsish status]");
}
-if ($?) { print "not ok 5 # POSIX status is $?\n"; }
-else { print "ok 5\n"; }
+is($?,0,"outer lex scope of vmsish [POSIX status]");
+
{
use vmsish qw(exit); # check import function
- if ($?) { print "not ok 6 # POSIX status is $?\n"; }
- else { print "ok 6\n"; }
+ is($?,0,"importing vmsish exit [POSIX status]");
}
#========== vmsish exit, messages ==========
@@ -35,39 +31,54 @@ else { print "ok 5\n"; }
use vmsish qw(status);
$msg = do_a_perl('-e "exit 1"');
- if ($msg !~ /ABORT/) {
$msg =~ s/\n/\\n/g; # keep output on one line
- print "not ok 7 # subprocess output: |$msg|\n";
- }
- else { print "ok 7\n"; }
- if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
- else { print "ok 8\n"; }
+ like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
+ is($?&1,0,"vmsish status check, POSIX ERR exit");
$msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
- if (length $msg) {
$msg =~ s/\n/\\n/g; # keep output on one line
- print "not ok 9 # subprocess output: |$msg|\n";
- }
- else { print "ok 9\n"; }
- if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
- else { print "ok 10\n"; }
+ ok(length($msg)==0,"vmsish OK exit, DCL error message check");
+ is($?&1,1, "vmsish status check, vmsish OK exit");
$msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
- if ($msg !~ /ABORT/) {
$msg =~ s/\n/\\n/g; # keep output on one line
- print "not ok 11 # subprocess output: |$msg|\n";
- }
- else { print "ok 11\n"; }
- if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
- else { print "ok 12\n"; }
+ like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
+ is($?&1,0,"vmsish ERR exit, vmsish status check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
$msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
- if ($msg =~ /ABORT/) {
$msg =~ s/\n/\\n/g; # keep output on one line
- print "not ok 13 # subprocess output: |$msg|\n";
- }
- else { print "ok 13\n"; }
-
+ ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
+
+ local *TEST;
+ open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');
+ print TEST "#! perl\n";
+ print TEST "use vmsish qw(hushed);\n";
+ print TEST "\$obvious = (\$compile(\$error;\n";
+ close TEST;
+ $msg = do_a_perl('vmsish_test.pl');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
+ unlink 'vmsish_test.pl';
}
@@ -84,7 +95,7 @@ else { print "ok 5\n"; }
gmtime(0); # Force reset of tz offset
}
{
- use vmsish qw(time);
+ use_ok('vmsish qw(time)');
$vmstime = time;
@vmslocal = localtime($vmstime);
@vmsgmtime = gmtime($vmstime);
@@ -101,33 +112,21 @@ else { print "ok 5\n"; }
# since it's unlikely local time will differ from UTC by so small
# an amount, and it renders the test resistant to delays from
# things like stat() on a file mounted over a slow network link.
- if ($utctime - $vmstime + $offset > 10) {
- print "not ok 14 # (time) UTC: $utctime VMS: $vmstime\n";
- }
- else { print "ok 14\n"; }
+ ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime");
$utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
$utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0];
$vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
$vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0];
- if ($vmsval - $utcval + $offset > 10) {
- print "not ok 15 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
- }
- else { print "ok 15\n"; }
+ ok($vmsval - $utcval + $offset <= 10, "(localtime)\n# UTC: @utclocal\n# VMS: @vmslocal");
$utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
$utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0];
$vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
$vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0];
- if ($vmsval - $utcval + $offset > 10) {
- print "not ok 16 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
- }
- else { print "ok 16\n"; }
+ ok($vmsval - $utcval + $offset <= 10, "(gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime");
- if ($vmsmtime - $utcmtime + $offset > 10) {
- print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n";
- }
- else { print "ok 17\n"; }
+ ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime");
}
#====== need this to make sure error messages come out, even if
View Lorry Controller Status