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