1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    @INC = '../lib'; 
6}
7
8my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
9
10require "./test.pl";
11plan(tests => 25);
12
13SKIP: {
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
24SKIP: {
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.
29is($?,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}
40is($?,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
116  # Unless we are prepared to parse the timezone rules here and figure out
117  # what the correct offset was when the file was last revised, we need to 
118  # use a file for which the current offset is known to be valid.  That's why
119  # we create a file rather than using an existing one for the stat() test.
120
121  my $file = 'sys$scratch:vmsish_t_flirble.tmp';
122  open TMP, ">$file" or die "Couldn't open file $file";
123  close TMP;
124  END { 1 while unlink $file; }
125
126  {
127     use_ok('vmsish qw(time)');
128
129     # but that didn't get it in our current scope
130     use vmsish qw(time);
131
132     $vmstime   = time;
133     @vmslocal  = localtime($vmstime);
134     @vmsgmtime = gmtime($vmstime);
135     $vmsmtime  = (stat $file)[9];
136  }
137  $utctime   = time;
138  @utclocal  = localtime($vmstime);
139  @utcgmtime = gmtime($vmstime);
140  $utcmtime  = (stat $file)[9];
141  
142  $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
143
144  # We allow lots of leeway (10 sec) difference for these tests,
145  # since it's unlikely local time will differ from UTC by so small
146  # an amount, and it renders the test resistant to delays from
147  # things like stat() on a file mounted over a slow network link.
148  ok(abs($utctime - $vmstime + $offset) <= 10,"(time) UTC: $utctime VMS: $vmstime");
149
150  $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
151            $utclocal[2] * 3600     + $utclocal[1] * 60 + $utclocal[0];
152  $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
153            $vmslocal[2] * 3600     + $vmslocal[1] * 60 + $vmslocal[0];
154  ok(abs($vmsval - $utcval + $offset) <= 10, "(localtime) UTC: $utcval  VMS: $vmsval");
155  print "# UTC: @utclocal\n# VMS: @vmslocal\n";
156
157  $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
158            $utcgmtime[2] * 3600     + $utcgmtime[1] * 60 + $utcgmtime[0];
159  $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
160            $vmsgmtime[2] * 3600     + $vmsgmtime[1] * 60 + $vmsgmtime[0];
161  ok(abs($vmsval - $utcval + $offset) <= 10, "(gmtime) UTC: $utcval  VMS: $vmsval");
162  print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
163
164  ok(abs($utcmtime - $vmsmtime + $offset) <= 10,"(stat) UTC: $utcmtime  VMS: $vmsmtime");
165}
166}
167
168#====== need this to make sure error messages come out, even if
169#       they were turned off in invoking procedure
170sub do_a_perl {
171    local *P;
172    open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing');
173    print P "\$ set message/facil/sever/ident/text\n";
174    print P "\$ define/nolog/user sys\$error _nla0:\n";
175    print P "\$ $Invoke_Perl @_\n";
176    close P;
177    my $x = `\@vmsish_test.com`;
178    unlink 'vmsish_test.com';
179    return $x;
180}
181
182