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