1 | |
---|
2 | BEGIN { unshift @INC, '[-.lib]'; } |
---|
3 | |
---|
4 | my $Invoke_Perl = qq(MCR $^X "-I[-.lib]"); |
---|
5 | |
---|
6 | print "1..17\n"; |
---|
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 | |
---|
33 | #========== vmsish exit, messages ========== |
---|
34 | { |
---|
35 | use vmsish qw(status); |
---|
36 | |
---|
37 | $msg = do_a_perl('-e "exit 1"'); |
---|
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 | |
---|
46 | $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"'); |
---|
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 | |
---|
55 | $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"'); |
---|
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"; } |
---|
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 | |
---|
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) { |
---|
105 | print "not ok 14 # (time) UTC: $utctime VMS: $vmstime\n"; |
---|
106 | } |
---|
107 | else { print "ok 14\n"; } |
---|
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) { |
---|
114 | print "not ok 15 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n"; |
---|
115 | } |
---|
116 | else { print "ok 15\n"; } |
---|
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) { |
---|
123 | print "not ok 16 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; |
---|
124 | } |
---|
125 | else { print "ok 16\n"; } |
---|
126 | |
---|
127 | if ($vmsmtime - $utcmtime + $offset > 10) { |
---|
128 | print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n"; |
---|
129 | } |
---|
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"; |
---|
139 | print P "\$ define/nolog/user sys\$error _nla0:\n"; |
---|
140 | print P "\$ $Invoke_Perl @_\n"; |
---|
141 | close P; |
---|
142 | my $x = `\@vmsish_test.com`; |
---|
143 | unlink 'vmsish_test.com'; |
---|
144 | return $x; |
---|
145 | } |
---|
146 | |
---|