This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
applied suggested patch, modulo already applied parts
[perl5.git] / vms / ext / vmsish.t
1
2 BEGIN { unshift @INC, '[-.lib]'; }
3
4 my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
5
6 print "1..16\n";
7
8 #========== vmsish status ==========
9 `$Invoke_Perl -e 1`;  # Avoid system() from a pipe from harness.  Mutter.
10 if ($?) { print "not ok 1 # POSIX status is $?\n"; }
11 else    { print "ok 1\n"; }
12 {
13   use vmsish qw(status);
14   if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; }
15   else              { print "ok 2\n"; }
16   {
17     no vmsish '$?'; # check unimport function
18     if ($?) { print "not ok 3 # POSIX status is $?\n"; }
19     else    { print "ok 3\n"; }
20   }
21   # and lexical scoping
22   if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; }
23   else              { print "ok 4\n"; }
24 }
25 if ($?) { print "not ok 5 # POSIX status is $?\n"; }
26 else    { print "ok 5\n";                          }
27 {
28   use vmsish qw(exit);  # check import function
29   if ($?) { print "not ok 6 # POSIX status is $?\n"; }
30   else    { print "ok 6\n"; }
31 }
32
33 #========== vmsish exit ==========
34 {
35   use vmsish qw(status);
36   my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`;
37   if ($msg !~ /ABORT/) {
38     $msg =~ s/\n/\\n/g; # keep output on one line
39     print "not ok 7 # subprocess output: |$msg|\n";
40   }
41   else { print "ok 7\n"; }
42   if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
43   else        { print "ok 8\n"; }
44
45   $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`;
46   if (length $msg) {
47     $msg =~ s/\n/\\n/g; # keep output on one line
48     print "not ok 9 # subprocess output: |$msg|\n";
49   }
50   else { print "ok 9\n"; }
51   if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
52   else              { print "ok 10\n"; }
53
54   $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`;
55   if ($msg !~ /ABORT/) {
56     $msg =~ s/\n/\\n/g; # keep output on one line
57     print "not ok 11 # subprocess output: |$msg|\n";
58   }
59   else { print "ok 11\n"; }
60   if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
61   else        { print "ok 12\n"; }
62 }
63
64
65 #========== vmsish time ==========
66 {
67   my($utctime, @utclocal, @utcgmtime, $utcmtime,
68      $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
69      $utcval,  $vmaval, $offset);
70   # Make sure apparent local time isn't GMT
71   if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
72     $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
73     $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
74     eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
75     gmtime(0); # Force reset of tz offset
76   }
77   {
78      use vmsish qw(time);
79      $vmstime   = time;
80      @vmslocal  = localtime($vmstime);
81      @vmsgmtime = gmtime($vmstime);
82      $vmsmtime  = (stat $0)[9];
83   }
84   $utctime   = time;
85   @utclocal  = localtime($vmstime);
86   @utcgmtime = gmtime($vmstime);
87   $utcmtime  = (stat $0)[9];
88   
89   $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
90
91   # We allow lots of leeway (10 sec) difference for these tests,
92   # since it's unlikely local time will differ from UTC by so small
93   # an amount, and it renders the test resistant to delays from
94   # things like stat() on a file mounted over a slow network link.
95   if ($utctime - $vmstime + $offset > 10) {
96     print "not ok 13  # (time) UTC: $utctime  VMS: $vmstime\n";
97   }
98   else { print "ok 13\n"; }
99
100   $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
101             $utclocal[2] * 3600     + $utclocal[1] * 60 + $utclocal[0];
102   $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
103             $vmslocal[2] * 3600     + $vmslocal[1] * 60 + $vmslocal[0];
104   if ($vmsval - $utcval + $offset > 10) {
105     print "not ok 14  # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
106   }
107   else { print "ok 14\n"; }
108
109   $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
110             $utcgmtime[2] * 3600     + $utcgmtime[1] * 60 + $utcgmtime[0];
111   $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
112             $vmsgmtime[2] * 3600     + $vmsgmtime[1] * 60 + $vmsgmtime[0];
113   if ($vmsval - $utcval + $offset > 10) {
114     print "not ok 15  # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
115   }
116   else { print "ok 15\n"; }
117
118   if ($vmsmtime - $utcmtime + $offset > 10) {
119     print "not ok 16  # (stat) UTC: $utcmtime  VMS: $vmsmtime\n";
120   }
121   else { print "ok 16\n"; }
122 }