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