Rename tied_handle_method() to tied_method(), and make it non-static.
[perl.git] / lib / vmsish.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     @INC = '../lib'; 
6 }
7
8 my $perl = $^X;
9 $perl = VMS::Filespec::vmsify($perl) if $^O eq 'VMS';
10
11 my $Invoke_Perl = qq(MCR $perl "-I[-.lib]");
12
13 BEGIN { require "./test.pl"; }
14 plan(tests => 25);
15
16 SKIP: {
17     skip("tests for non-VMS only", 1) if $^O eq 'VMS';
18
19     no utf8;
20
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';
29
30 #========== vmsish status ==========
31 `$Invoke_Perl -e 1`;  # Avoid system() from a pipe from harness.  Mutter.
32 is($?,0,"simple Perl invokation: POSIX success status");
33 {
34   use vmsish qw(status);
35   is(($? & 1),1, "importing vmsish [vmsish status]");
36   {
37     no vmsish qw(status); # check unimport function
38     is($?,0, "unimport vmsish [POSIX STATUS]");
39   }
40   # and lexical scoping
41   is(($? & 1),1,"lex scope of vmsish [vmsish status]");
42 }
43 is($?,0,"outer lex scope of vmsish [POSIX status]");
44
45 {
46   use vmsish qw(exit);  # check import function
47   is($?,0,"importing vmsish exit [POSIX status]");
48 }
49
50 #========== vmsish exit, messages ==========
51 {
52   use vmsish qw(status);
53
54   $msg = do_a_perl('-e "exit 1"');
55     $msg =~ s/\n/\\n/g; # keep output on one line
56   like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
57   is($?&1,0,"vmsish status check, POSIX ERR exit");
58
59   $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
60     $msg =~ s/\n/\\n/g; # keep output on one line
61   ok(length($msg)==0,"vmsish OK exit, DCL error message check");
62   is($?&1,1, "vmsish status check, vmsish OK exit");
63
64   $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
65     $msg =~ s/\n/\\n/g; # keep output on one line
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");
72
73   $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
74     $msg =~ s/\n/\\n/g; # keep output on one line
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';
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   }
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
129   {
130      use_ok('vmsish qw(time)');
131
132      # but that didn't get it in our current scope
133      use vmsish qw(time);
134
135      $vmstime   = time;
136      @vmslocal  = localtime($vmstime);
137      @vmsgmtime = gmtime($vmstime);
138      $vmsmtime  = (stat $file)[9];
139   }
140   $utctime   = time;
141   @utclocal  = localtime($vmstime);
142   @utcgmtime = gmtime($vmstime);
143   $utcmtime  = (stat $file)[9];
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.
151   ok(abs($utctime - $vmstime + $offset) <= 10,"(time) UTC: $utctime VMS: $vmstime");
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];
157   ok(abs($vmsval - $utcval + $offset) <= 10, "(localtime) UTC: $utcval  VMS: $vmsval");
158   print "# UTC: @utclocal\n# VMS: @vmslocal\n";
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];
164   ok(abs($vmsval - $utcval + $offset) <= 10, "(gmtime) UTC: $utcval  VMS: $vmsval");
165   print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
166
167   ok(abs($utcmtime - $vmsmtime + $offset) <= 10,"(stat) UTC: $utcmtime  VMS: $vmsmtime");
168 }
169 }
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";
177     print P "\$ define/nolog/user sys\$error _nla0:\n";
178     print P "\$ $Invoke_Perl @_\n";
179     close P;
180     my $x = `\@vmsish_test.com`;
181     unlink 'vmsish_test.com';
182     return $x;
183 }
184