2 BEGIN { unshift @INC, '[-.lib]'; }
4 my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
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"; }
13 use vmsish qw(status);
14 if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; }
15 else { print "ok 2\n"; }
17 no vmsish '$?'; # check unimport function
18 if ($?) { print "not ok 3 # POSIX status is $?\n"; }
19 else { print "ok 3\n"; }
22 if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; }
23 else { print "ok 4\n"; }
25 if ($?) { print "not ok 5 # POSIX status is $?\n"; }
26 else { print "ok 5\n"; }
28 use vmsish qw(exit); # check import function
29 if ($?) { print "not ok 6 # POSIX status is $?\n"; }
30 else { print "ok 6\n"; }
33 #========== vmsish exit, messages ==========
35 use vmsish qw(status);
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";
42 else { print "ok 7\n"; }
43 if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
44 else { print "ok 8\n"; }
46 $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
48 $msg =~ s/\n/\\n/g; # keep output on one line
49 print "not ok 9 # subprocess output: |$msg|\n";
51 else { print "ok 9\n"; }
52 if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
53 else { print "ok 10\n"; }
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";
60 else { print "ok 11\n"; }
61 if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
62 else { print "ok 12\n"; }
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";
69 else { print "ok 13\n"; }
74 #========== vmsish time ==========
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
89 @vmslocal = localtime($vmstime);
90 @vmsgmtime = gmtime($vmstime);
91 $vmsmtime = (stat $0)[9];
94 @utclocal = localtime($vmstime);
95 @utcgmtime = gmtime($vmstime);
96 $utcmtime = (stat $0)[9];
98 $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
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";
107 else { print "ok 14\n"; }
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";
116 else { print "ok 15\n"; }
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";
125 else { print "ok 16\n"; }
127 if ($vmsmtime - $utcmtime + $offset > 10) {
128 print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n";
130 else { print "ok 17\n"; }
133 #====== need this to make sure error messages come out, even if
134 # they were turned off in invoking procedure
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";
142 my $x = `\@vmsish_test.com`;
143 unlink 'vmsish_test.com';