9 $perl = VMS::Filespec::vmsify($perl) if $^O eq 'VMS';
11 my $Invoke_Perl = qq(MCR $perl "-I[-.lib]");
13 use Test::More tests => 25;
16 skip("tests for non-VMS only", 1) if $^O eq 'VMS';
20 BEGIN { $Orig_Bits = $^H }
22 # make sure that all those 'use vmsish' calls didn't do anything.
23 is( $Orig_Bits, $^H, 'use vmsish a no-op' );
27 skip("tests for VMS only", 24) unless $^O eq 'VMS';
29 #========== vmsish status ==========
30 `$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
31 is($?,0,"simple Perl invocation: POSIX success status");
33 use vmsish qw(status);
34 is(($? & 1),1, "importing vmsish [vmsish status]");
36 no vmsish qw(status); # check unimport function
37 is($?,0, "unimport vmsish [POSIX STATUS]");
40 is(($? & 1),1,"lex scope of vmsish [vmsish status]");
42 is($?,0,"outer lex scope of vmsish [POSIX status]");
45 use vmsish qw(exit); # check import function
46 is($?,0,"importing vmsish exit [POSIX status]");
49 #========== vmsish exit, messages ==========
51 use vmsish qw(status);
53 $msg = do_a_perl('-e "exit 1"');
54 $msg =~ s/\n/\\n/g; # keep output on one line
55 like($msg, qr/ABORT/, "POSIX ERR exit, DCL error message check");
56 is($?&1,0,"vmsish status check, POSIX ERR exit");
58 $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
59 $msg =~ s/\n/\\n/g; # keep output on one line
60 ok(length($msg)==0,"vmsish OK exit, DCL error message check");
61 is($?&1,1, "vmsish status check, vmsish OK exit");
63 $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
64 $msg =~ s/\n/\\n/g; # keep output on one line
65 like($msg, qr/ABORT/, "vmsish ERR exit, DCL error message check");
66 is($?&1,0,"vmsish ERR exit, vmsish status check");
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");
72 $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
73 $msg =~ s/\n/\\n/g; # keep output on one line
74 ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
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
78 like($msg, qr/ABORT/,"vmsish ERR exit, no vmsish hushed, DCL error message check");
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");
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");
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");
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";
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';
105 #========== vmsish time ==========
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
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.
123 my $file = 'sys$scratch:vmsish_t_flirble.tmp';
124 open TMP, ">$file" or die "Couldn't open file $file";
126 END { 1 while unlink $file; }
129 use_ok('vmsish', 'time');
131 # but that didn't get it in our current scope
135 @vmslocal = localtime($vmstime);
136 @vmsgmtime = gmtime($vmstime);
137 $vmsmtime = (stat $file)[9];
140 @utclocal = localtime($vmstime);
141 @utcgmtime = gmtime($vmstime);
142 $utcmtime = (stat $file)[9];
144 $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
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.
150 ok(abs($utctime - $vmstime + $offset) <= 10,"(time) UTC: $utctime VMS: $vmstime");
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];
156 ok(abs($vmsval - $utcval + $offset) <= 10, "(localtime) UTC: $utcval VMS: $vmsval");
157 print "# UTC: @utclocal\n# VMS: @vmslocal\n";
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];
163 ok(abs($vmsval - $utcval + $offset) <= 10, "(gmtime) UTC: $utcval VMS: $vmsval");
164 print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
166 ok(abs($utcmtime - $vmsmtime + $offset) <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime");
170 #====== need this to make sure error messages come out, even if
171 # they were turned off in invoking procedure
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";
176 print P "\$ define/nolog/user sys\$error _nla0:\n";
177 print P "\$ $Invoke_Perl @_\n";
179 my $x = `\@vmsish_test.com`;
180 unlink 'vmsish_test.com';