This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
applied suggested patch, modulo already applied parts
[perl5.git] / vms / ext / vmsish.t
CommitLineData
68dc0745
PP
1
2BEGIN { unshift @INC, '[-.lib]'; }
3
4my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
5
6print "1..16\n";
7
8#========== vmsish status ==========
9`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
10if ($?) { print "not ok 1 # POSIX status is $?\n"; }
11else { print "ok 1\n"; }
12{
13 use vmsish qw(status);
14 if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; }
15 else { print "ok 2\n"; }
16 {
17 no vmsish '$?'; # check unimport function
18 if ($?) { print "not ok 3 # POSIX status is $?\n"; }
19 else { print "ok 3\n"; }
20 }
21 # and lexical scoping
22 if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; }
23 else { print "ok 4\n"; }
24}
25if ($?) { print "not ok 5 # POSIX status is $?\n"; }
26else { print "ok 5\n"; }
27{
28 use vmsish qw(exit); # check import function
29 if ($?) { print "not ok 6 # POSIX status is $?\n"; }
30 else { print "ok 6\n"; }
31}
32
33#========== vmsish exit ==========
34{
35 use vmsish qw(status);
36 my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`;
37 if ($msg !~ /ABORT/) {
38 $msg =~ s/\n/\\n/g; # keep output on one line
39 print "not ok 7 # subprocess output: |$msg|\n";
40 }
41 else { print "ok 7\n"; }
42 if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
43 else { print "ok 8\n"; }
44
45 $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`;
46 if (length $msg) {
47 $msg =~ s/\n/\\n/g; # keep output on one line
48 print "not ok 9 # subprocess output: |$msg|\n";
49 }
50 else { print "ok 9\n"; }
51 if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
52 else { print "ok 10\n"; }
53
54 $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`;
55 if ($msg !~ /ABORT/) {
56 $msg =~ s/\n/\\n/g; # keep output on one line
57 print "not ok 11 # subprocess output: |$msg|\n";
58 }
59 else { print "ok 11\n"; }
60 if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
61 else { print "ok 12\n"; }
62}
63
64
65#========== vmsish time ==========
66{
67 my($utctime, @utclocal, @utcgmtime, $utcmtime,
68 $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
69 $utcval, $vmaval, $offset);
70 # Make sure apparent local time isn't GMT
71 if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
72 $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
73 $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
74 eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
75 gmtime(0); # Force reset of tz offset
76 }
77 {
78 use vmsish qw(time);
79 $vmstime = time;
80 @vmslocal = localtime($vmstime);
81 @vmsgmtime = gmtime($vmstime);
82 $vmsmtime = (stat $0)[9];
83 }
84 $utctime = time;
85 @utclocal = localtime($vmstime);
86 @utcgmtime = gmtime($vmstime);
87 $utcmtime = (stat $0)[9];
88
89 $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
90
91 # We allow lots of leeway (10 sec) difference for these tests,
92 # since it's unlikely local time will differ from UTC by so small
93 # an amount, and it renders the test resistant to delays from
94 # things like stat() on a file mounted over a slow network link.
95 if ($utctime - $vmstime + $offset > 10) {
96 print "not ok 13 # (time) UTC: $utctime VMS: $vmstime\n";
97 }
98 else { print "ok 13\n"; }
99
100 $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
101 $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0];
102 $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
103 $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0];
104 if ($vmsval - $utcval + $offset > 10) {
105 print "not ok 14 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
106 }
107 else { print "ok 14\n"; }
108
109 $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
110 $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0];
111 $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
112 $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0];
113 if ($vmsval - $utcval + $offset > 10) {
114 print "not ok 15 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
115 }
116 else { print "ok 15\n"; }
117
3eeba6fb 118 if ($vmsmtime - $utcmtime + $offset > 10) {
68dc0745
PP
119 print "not ok 16 # (stat) UTC: $utcmtime VMS: $vmsmtime\n";
120 }
121 else { print "ok 16\n"; }
122}