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 CB |
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 CB |
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 CB |
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 CB |
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 |