This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
aad4a4a66f8fe12d29afda2b40002131c8138007
[perl5.git] / lib / vmsish.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib'; 
6 }
7
8 my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
9
10 require "./test.pl";
11 plan(tests => 25);
12
13 SKIP: {
14     skip("tests for non-VMS only", 1) if $^O eq 'VMS';
15
16     no utf8;
17
18     BEGIN { $Orig_Bits = $^H }
19
20     # make sure that all those 'use vmsish' calls didn't do anything.
21     is( $Orig_Bits, $^H,    'use vmsish a no-op' );
22 }
23
24 SKIP: {
25     skip("tests for VMS only", 24) unless $^O eq 'VMS';
26
27 #========== vmsish status ==========
28 `$Invoke_Perl -e 1`;  # Avoid system() from a pipe from harness.  Mutter.
29 is($?,0,"simple Perl invokation: POSIX success status");
30 {
31   use vmsish qw(status);
32   is(($? & 1),1, "importing vmsish [vmsish status]");
33   {
34     no vmsish qw(status); # check unimport function
35     is($?,0, "unimport vmsish [POSIX STATUS]");
36   }
37   # and lexical scoping
38   is(($? & 1),1,"lex scope of vmsish [vmsish status]");
39 }
40 is($?,0,"outer lex scope of vmsish [POSIX status]");
41
42 {
43   use vmsish qw(exit);  # check import function
44   is($?,0,"importing vmsish exit [POSIX status]");
45 }
46
47 #========== vmsish exit, messages ==========
48 {
49   use vmsish qw(status);
50
51   $msg = do_a_perl('-e "exit 1"');
52     $msg =~ s/\n/\\n/g; # keep output on one line
53   like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
54   is($?&1,0,"vmsish status check, POSIX ERR exit");
55
56   $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
57     $msg =~ s/\n/\\n/g; # keep output on one line
58   ok(length($msg)==0,"vmsish OK exit, DCL error message check");
59   is($?&1,1, "vmsish status check, vmsish OK exit");
60
61   $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
62     $msg =~ s/\n/\\n/g; # keep output on one line
63   like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
64   is($?&1,0,"vmsish ERR exit, vmsish status check");
65
66   $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
67   $msg =~ s/\n/\\n/g; # keep output on one line
68   ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
69
70   $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
71     $msg =~ s/\n/\\n/g; # keep output on one line
72   ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
73
74   $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
75   $msg =~ s/\n/\\n/g; # keep output on one line
76   like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
77
78   $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
79   $msg =~ s/\n/\\n/g; # keep output on one line
80   ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
81
82   $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
83   $msg =~ s/\n/\\n/g; # keep output on one line
84   ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
85
86   $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
87   $msg =~ s/\n/\\n/g; # keep output on one line
88   ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
89
90   local *TEST;
91   open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');  
92   print TEST "#! perl\n";
93   print TEST "use vmsish qw(hushed);\n";
94   print TEST "\$obvious = (\$compile(\$error;\n";
95   close TEST;
96   $msg = do_a_perl('vmsish_test.pl');
97   $msg =~ s/\n/\\n/g; # keep output on one line
98   ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
99   unlink 'vmsish_test.pl';
100 }
101
102
103 #========== vmsish time ==========
104 {
105   my($utctime, @utclocal, @utcgmtime, $utcmtime,
106      $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
107      $utcval,  $vmaval, $offset);
108   # Make sure apparent local time isn't GMT
109   if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
110     $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
111     $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
112     eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
113     gmtime(0); # Force reset of tz offset
114   }
115   # This test script might have been invoked in at least one of four different ways:
116   #     perl lib/vmsish.t
117   #     perl [.lib]vmsish.t
118   #     set def [.t] && perl ../lib/vmsish.t
119   #     set def [.t] && perl [-.lib]vmsish.t
120   # In the following we attempt to find ourselves without resorting to VMS::Filespec.
121   # Note that the chdir in the BEGIN block above complicates matters.
122   my $self = $0;
123   if ( ! -e $self && -e "../$0" ) { $self = "../$0"; }
124   if ( ! -e $self ) {
125       $self =~ s/\[//;
126       $self = "[-$self";
127   }
128   {
129      use_ok('vmsish qw(time)');
130
131      # but that didn't get it in our current scope
132      use vmsish qw(time);
133
134      $vmstime   = time;
135      @vmslocal  = localtime($vmstime);
136      @vmsgmtime = gmtime($vmstime);
137      $vmsmtime  = (stat $self)[9];
138   }
139   $utctime   = time;
140   @utclocal  = localtime($vmstime);
141   @utcgmtime = gmtime($vmstime);
142   $utcmtime  = (stat $self)[9];
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.
150   ok(abs($utctime - $vmstime + $offset) <= 10,"(time) UTC: $utctime VMS: $vmstime");
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];
156   ok(abs($vmsval - $utcval + $offset) <= 10, "(localtime) UTC: $utcval  VMS: $vmsval");
157   print "# UTC: @utclocal\n# VMS: @vmslocal\n";
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];
163   ok(abs($vmsval - $utcval + $offset) <= 10, "(gmtime) UTC: $utcval  VMS: $vmsval");
164   print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
165
166   ok(abs($utcmtime - $vmsmtime + $offset) <= 10,"(stat) UTC: $utcmtime  VMS: $vmsmtime");
167 }
168 }
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";
176     print P "\$ define/nolog/user sys\$error _nla0:\n";
177     print P "\$ $Invoke_Perl @_\n";
178     close P;
179     my $x = `\@vmsish_test.com`;
180     unlink 'vmsish_test.com';
181     return $x;
182 }
183