Commit | Line | Data |
---|---|---|
9f84c005 | 1 | #!./perl |
68dc0745 | 2 | |
9f84c005 MS |
3 | BEGIN { |
4 | chdir 't' if -d 't'; | |
5 | @INC = '../lib'; | |
6 | } | |
68dc0745 | 7 | |
16ed4686 JM |
8 | my $perl = $^X; |
9 | $perl = VMS::Filespec::vmsify($perl) if $^O eq 'VMS'; | |
10 | ||
11 | my $Invoke_Perl = qq(MCR $perl "-I[-.lib]"); | |
68dc0745 | 12 | |
768fd157 | 13 | BEGIN { require "./test.pl"; } |
9f84c005 MS |
14 | plan(tests => 25); |
15 | ||
16 | SKIP: { | |
17 | skip("tests for non-VMS only", 1) if $^O eq 'VMS'; | |
18 | ||
1e2e7acc JH |
19 | no utf8; |
20 | ||
9f84c005 MS |
21 | BEGIN { $Orig_Bits = $^H } |
22 | ||
23 | # make sure that all those 'use vmsish' calls didn't do anything. | |
24 | is( $Orig_Bits, $^H, 'use vmsish a no-op' ); | |
25 | } | |
26 | ||
27 | SKIP: { | |
28 | skip("tests for VMS only", 24) unless $^O eq 'VMS'; | |
68dc0745 | 29 | |
30 | #========== vmsish status ========== | |
31 | `$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter. | |
96e176bf | 32 | is($?,0,"simple Perl invokation: POSIX success status"); |
68dc0745 | 33 | { |
34 | use vmsish qw(status); | |
96e176bf | 35 | is(($? & 1),1, "importing vmsish [vmsish status]"); |
68dc0745 | 36 | { |
96e176bf CL |
37 | no vmsish qw(status); # check unimport function |
38 | is($?,0, "unimport vmsish [POSIX STATUS]"); | |
68dc0745 | 39 | } |
40 | # and lexical scoping | |
96e176bf | 41 | is(($? & 1),1,"lex scope of vmsish [vmsish status]"); |
68dc0745 | 42 | } |
96e176bf CL |
43 | is($?,0,"outer lex scope of vmsish [POSIX status]"); |
44 | ||
68dc0745 | 45 | { |
46 | use vmsish qw(exit); # check import function | |
96e176bf | 47 | is($?,0,"importing vmsish exit [POSIX status]"); |
68dc0745 | 48 | } |
49 | ||
925fd5a3 | 50 | #========== vmsish exit, messages ========== |
68dc0745 | 51 | { |
52 | use vmsish qw(status); | |
925fd5a3 CB |
53 | |
54 | $msg = do_a_perl('-e "exit 1"'); | |
68dc0745 | 55 | $msg =~ s/\n/\\n/g; # keep output on one line |
96e176bf CL |
56 | like($msg,'ABORT', "POSIX ERR exit, DCL error message check"); |
57 | is($?&1,0,"vmsish status check, POSIX ERR exit"); | |
68dc0745 | 58 | |
925fd5a3 | 59 | $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"'); |
68dc0745 | 60 | $msg =~ s/\n/\\n/g; # keep output on one line |
96e176bf CL |
61 | ok(length($msg)==0,"vmsish OK exit, DCL error message check"); |
62 | is($?&1,1, "vmsish status check, vmsish OK exit"); | |
68dc0745 | 63 | |
925fd5a3 | 64 | $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"'); |
68dc0745 | 65 | $msg =~ s/\n/\\n/g; # keep output on one line |
96e176bf CL |
66 | like($msg, 'ABORT', "vmsish ERR exit, DCL error message check"); |
67 | is($?&1,0,"vmsish ERR exit, vmsish status check"); | |
68 | ||
69 | $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"'); | |
70 | $msg =~ s/\n/\\n/g; # keep output on one line | |
71 | ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check"); | |
925fd5a3 CB |
72 | |
73 | $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"'); | |
925fd5a3 | 74 | $msg =~ s/\n/\\n/g; # keep output on one line |
96e176bf CL |
75 | ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check"); |
76 | ||
77 | $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"'); | |
78 | $msg =~ s/\n/\\n/g; # keep output on one line | |
79 | like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check"); | |
80 | ||
81 | $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"'); | |
82 | $msg =~ s/\n/\\n/g; # keep output on one line | |
83 | ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check"); | |
84 | ||
85 | $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"'); | |
86 | $msg =~ s/\n/\\n/g; # keep output on one line | |
87 | ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check"); | |
88 | ||
89 | $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"'); | |
90 | $msg =~ s/\n/\\n/g; # keep output on one line | |
91 | ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check"); | |
92 | ||
93 | local *TEST; | |
94 | open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing'); | |
95 | print TEST "#! perl\n"; | |
96 | print TEST "use vmsish qw(hushed);\n"; | |
97 | print TEST "\$obvious = (\$compile(\$error;\n"; | |
98 | close TEST; | |
99 | $msg = do_a_perl('vmsish_test.pl'); | |
100 | $msg =~ s/\n/\\n/g; # keep output on one line | |
101 | ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check"); | |
102 | unlink 'vmsish_test.pl'; | |
68dc0745 | 103 | } |
104 | ||
105 | ||
106 | #========== vmsish time ========== | |
107 | { | |
108 | my($utctime, @utclocal, @utcgmtime, $utcmtime, | |
109 | $vmstime, @vmslocal, @vmsgmtime, $vmsmtime, | |
110 | $utcval, $vmaval, $offset); | |
111 | # Make sure apparent local time isn't GMT | |
112 | if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) { | |
113 | $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; | |
114 | $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600; | |
115 | eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }"; | |
116 | gmtime(0); # Force reset of tz offset | |
117 | } | |
86c16cb1 CB |
118 | |
119 | # Unless we are prepared to parse the timezone rules here and figure out | |
120 | # what the correct offset was when the file was last revised, we need to | |
121 | # use a file for which the current offset is known to be valid. That's why | |
122 | # we create a file rather than using an existing one for the stat() test. | |
123 | ||
124 | my $file = 'sys$scratch:vmsish_t_flirble.tmp'; | |
125 | open TMP, ">$file" or die "Couldn't open file $file"; | |
126 | close TMP; | |
127 | END { 1 while unlink $file; } | |
128 | ||
68dc0745 | 129 | { |
96e176bf | 130 | use_ok('vmsish qw(time)'); |
fb73e4b8 CB |
131 | |
132 | # but that didn't get it in our current scope | |
133 | use vmsish qw(time); | |
134 | ||
68dc0745 | 135 | $vmstime = time; |
136 | @vmslocal = localtime($vmstime); | |
137 | @vmsgmtime = gmtime($vmstime); | |
86c16cb1 | 138 | $vmsmtime = (stat $file)[9]; |
68dc0745 | 139 | } |
140 | $utctime = time; | |
141 | @utclocal = localtime($vmstime); | |
142 | @utcgmtime = gmtime($vmstime); | |
86c16cb1 | 143 | $utcmtime = (stat $file)[9]; |
68dc0745 | 144 | |
145 | $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}; | |
146 | ||
147 | # We allow lots of leeway (10 sec) difference for these tests, | |
148 | # since it's unlikely local time will differ from UTC by so small | |
149 | # an amount, and it renders the test resistant to delays from | |
150 | # things like stat() on a file mounted over a slow network link. | |
fb73e4b8 | 151 | ok(abs($utctime - $vmstime + $offset) <= 10,"(time) UTC: $utctime VMS: $vmstime"); |
68dc0745 | 152 | |
153 | $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 + | |
154 | $utclocal[2] * 3600 + $utclocal[1] * 60 + $utclocal[0]; | |
155 | $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 + | |
156 | $vmslocal[2] * 3600 + $vmslocal[1] * 60 + $vmslocal[0]; | |
fb73e4b8 | 157 | ok(abs($vmsval - $utcval + $offset) <= 10, "(localtime) UTC: $utcval VMS: $vmsval"); |
b6345914 | 158 | print "# UTC: @utclocal\n# VMS: @vmslocal\n"; |
68dc0745 | 159 | |
160 | $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 + | |
161 | $utcgmtime[2] * 3600 + $utcgmtime[1] * 60 + $utcgmtime[0]; | |
162 | $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 + | |
163 | $vmsgmtime[2] * 3600 + $vmsgmtime[1] * 60 + $vmsgmtime[0]; | |
fb73e4b8 | 164 | ok(abs($vmsval - $utcval + $offset) <= 10, "(gmtime) UTC: $utcval VMS: $vmsval"); |
b6345914 | 165 | print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n"; |
68dc0745 | 166 | |
fb73e4b8 | 167 | ok(abs($utcmtime - $vmsmtime + $offset) <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime"); |
925fd5a3 | 168 | } |
9f84c005 | 169 | } |
925fd5a3 CB |
170 | |
171 | #====== need this to make sure error messages come out, even if | |
172 | # they were turned off in invoking procedure | |
173 | sub do_a_perl { | |
174 | local *P; | |
175 | open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing'); | |
176 | print P "\$ set message/facil/sever/ident/text\n"; | |
399b8151 | 177 | print P "\$ define/nolog/user sys\$error _nla0:\n"; |
925fd5a3 CB |
178 | print P "\$ $Invoke_Perl @_\n"; |
179 | close P; | |
180 | my $x = `\@vmsish_test.com`; | |
181 | unlink 'vmsish_test.com'; | |
182 | return $x; | |
68dc0745 | 183 | } |
925fd5a3 | 184 |