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