Commit | Line | Data |
68dc0745 |
1 | |
2 | BEGIN { unshift @INC, '[-.lib]'; } |
3 | |
4 | my $Invoke_Perl = qq(MCR $^X "-I[-.lib]"); |
5 | |
925fd5a3 |
6 | print "1..17\n"; |
68dc0745 |
7 | |
8 | #========== vmsish status ========== |
9 | `$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter. |
10 | if ($?) { print "not ok 1 # POSIX status is $?\n"; } |
11 | else { 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 | } |
25 | if ($?) { print "not ok 5 # POSIX status is $?\n"; } |
26 | else { 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 | |
925fd5a3 |
33 | #========== vmsish exit, messages ========== |
68dc0745 |
34 | { |
35 | use vmsish qw(status); |
925fd5a3 |
36 | |
37 | $msg = do_a_perl('-e "exit 1"'); |
68dc0745 |
38 | if ($msg !~ /ABORT/) { |
39 | $msg =~ s/\n/\\n/g; # keep output on one line |
40 | print "not ok 7 # subprocess output: |$msg|\n"; |
41 | } |
42 | else { print "ok 7\n"; } |
43 | if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; } |
44 | else { print "ok 8\n"; } |
45 | |
925fd5a3 |
46 | $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"'); |
68dc0745 |
47 | if (length $msg) { |
48 | $msg =~ s/\n/\\n/g; # keep output on one line |
49 | print "not ok 9 # subprocess output: |$msg|\n"; |
50 | } |
51 | else { print "ok 9\n"; } |
52 | if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; } |
53 | else { print "ok 10\n"; } |
54 | |
925fd5a3 |
55 | $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"'); |
68dc0745 |
56 | if ($msg !~ /ABORT/) { |
57 | $msg =~ s/\n/\\n/g; # keep output on one line |
58 | print "not ok 11 # subprocess output: |$msg|\n"; |
59 | } |
60 | else { print "ok 11\n"; } |
61 | if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; } |
62 | else { print "ok 12\n"; } |
925fd5a3 |
63 | |
64 | $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"'); |
65 | if ($msg =~ /ABORT/) { |
66 | $msg =~ s/\n/\\n/g; # keep output on one line |
67 | print "not ok 13 # subprocess output: |$msg|\n"; |
68 | } |
69 | else { print "ok 13\n"; } |
70 | |
68dc0745 |
71 | } |
72 | |
73 | |
74 | #========== vmsish time ========== |
75 | { |
76 | my($utctime, @utclocal, @utcgmtime, $utcmtime, |
77 | $vmstime, @vmslocal, @vmsgmtime, $vmsmtime, |
78 | $utcval, $vmaval, $offset); |
79 | # Make sure apparent local time isn't GMT |
80 | if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) { |
81 | $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; |
82 | $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600; |
83 | eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }"; |
84 | gmtime(0); # Force reset of tz offset |
85 | } |
86 | { |
87 | use vmsish qw(time); |
88 | $vmstime = time; |
89 | @vmslocal = localtime($vmstime); |
90 | @vmsgmtime = gmtime($vmstime); |
91 | $vmsmtime = (stat $0)[9]; |
92 | } |
93 | $utctime = time; |
94 | @utclocal = localtime($vmstime); |
95 | @utcgmtime = gmtime($vmstime); |
96 | $utcmtime = (stat $0)[9]; |
97 | |
98 | $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; |
99 | |
100 | # We allow lots of leeway (10 sec) difference for these tests, |
101 | # since it's unlikely local time will differ from UTC by so small |
102 | # an amount, and it renders the test resistant to delays from |
103 | # things like stat() on a file mounted over a slow network link. |
104 | if ($utctime - $vmstime + $offset > 10) { |
925fd5a3 |
105 | print "not ok 14 # (time) UTC: $utctime VMS: $vmstime\n"; |
68dc0745 |
106 | } |
925fd5a3 |
107 | else { print "ok 14\n"; } |
68dc0745 |
108 | |
109 | $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 + |
110 | $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; |
111 | $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + |
112 | $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; |
113 | if ($vmsval - $utcval + $offset > 10) { |
925fd5a3 |
114 | print "not ok 15 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; |
68dc0745 |
115 | } |
925fd5a3 |
116 | else { print "ok 15\n"; } |
68dc0745 |
117 | |
118 | $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + |
119 | $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; |
120 | $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + |
121 | $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; |
122 | if ($vmsval - $utcval + $offset > 10) { |
925fd5a3 |
123 | print "not ok 16 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; |
68dc0745 |
124 | } |
925fd5a3 |
125 | else { print "ok 16\n"; } |
68dc0745 |
126 | |
3eeba6fb |
127 | if ($vmsmtime - $utcmtime + $offset > 10) { |
925fd5a3 |
128 | print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; |
68dc0745 |
129 | } |
925fd5a3 |
130 | else { print "ok 17\n"; } |
131 | } |
132 | |
133 | #====== need this to make sure error messages come out, even if |
134 | # they were turned off in invoking procedure |
135 | sub do_a_perl { |
136 | local *P; |
137 | open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); |
138 | print P "\$ set message/facil/sever/ident/text\n"; |
399b8151 |
139 | print P "\$ define/nolog/user sys\$error _nla0:\n"; |
925fd5a3 |
140 | print P "\$ $Invoke_Perl @_\n"; |
141 | close P; |
142 | my $x = `\@vmsish_test.com`; |
143 | unlink 'vmsish_test.com'; |
144 | return $x; |
68dc0745 |
145 | } |
925fd5a3 |
146 | |