vms/ext/vmsish.t

   1
   2 BEGIN { unshift @INC, '[-.lib]'; }
   3
   4 my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
   5
   6 print "1..17\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, messages ==========
  34 {
  35   use vmsish qw(status);
  36
  37   $msg = do_a_perl('-e "exit 1"');
  38   if ($msg !~ /ABORT/) {
  39     $msg =~ s/\n/\\n/g; # keep output on one line
  40     print "not ok 7 # subprocess output: |$msg|\n";
  41   }
  42   else { print "ok 7\n"; }
  43   if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
  44   else        { print "ok 8\n"; }
  45
  46   $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
  47   if (length $msg) {
  48     $msg =~ s/\n/\\n/g; # keep output on one line
  49     print "not ok 9 # subprocess output: |$msg|\n";
  50   }
  51   else { print "ok 9\n"; }
  52   if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
  53   else              { print "ok 10\n"; }
  54
  55   $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
  56   if ($msg !~ /ABORT/) {
  57     $msg =~ s/\n/\\n/g; # keep output on one line
  58     print "not ok 11 # subprocess output: |$msg|\n";
  59   }
  60   else { print "ok 11\n"; }
  61   if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
  62   else        { print "ok 12\n"; }
  63
  64   $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
  65   if ($msg =~ /ABORT/) {
  66     $msg =~ s/\n/\\n/g; # keep output on one line
  67     print "not ok 13 # subprocess output: |$msg|\n";
  68   }
  69   else { print "ok 13\n"; }
  70
  71 }
  72
  73
  74 #========== vmsish time ==========
  75 {
  76   my($utctime, @utclocal, @utcgmtime, $utcmtime,
  77      $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
  78      $utcval,  $vmaval, $offset);
  79   # Make sure apparent local time isn't GMT
  80   if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
  81     $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
  82     $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
  83     eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
  84     gmtime(0); # Force reset of tz offset
  85   }
  86   {
  87      use vmsish qw(time);
  88      $vmstime   = time;
  89      @vmslocal  = localtime($vmstime);
  90      @vmsgmtime = gmtime($vmstime);
  91      $vmsmtime  = (stat $0)[9];
  92   }
  93   $utctime   = time;
  94   @utclocal  = localtime($vmstime);
  95   @utcgmtime = gmtime($vmstime);
  96   $utcmtime  = (stat $0)[9];
  97
  98   $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
  99
 100   # We allow lots of leeway (10 sec) difference for these tests,
 101   # since it's unlikely local time will differ from UTC by so small
 102   # an amount, and it renders the test resistant to delays from
 103   # things like stat() on a file mounted over a slow network link.
 104   if ($utctime - $vmstime + $offset > 10) {
 105     print "not ok 14  # (time) UTC: $utctime  VMS: $vmstime\n";
 106   }
 107   else { print "ok 14\n"; }
 108
 109   $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
 110             $utclocal[2] * 3600     + $utclocal[1] * 60 + $utclocal[0];
 111   $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
 112             $vmslocal[2] * 3600     + $vmslocal[1] * 60 + $vmslocal[0];
 113   if ($vmsval - $utcval + $offset > 10) {
 114     print "not ok 15  # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
 115   }
 116   else { print "ok 15\n"; }
 117
 118   $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
 119             $utcgmtime[2] * 3600     + $utcgmtime[1] * 60 + $utcgmtime[0];
 120   $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
 121             $vmsgmtime[2] * 3600     + $vmsgmtime[1] * 60 + $vmsgmtime[0];
 122   if ($vmsval - $utcval + $offset > 10) {
 123     print "not ok 16  # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
 124   }
 125   else { print "ok 16\n"; }
 126
 127   if ($vmsmtime - $utcmtime + $offset > 10) {
 128     print "not ok 17  # (stat) UTC: $utcmtime  VMS: $vmsmtime\n";
 129   }
 130   else { print "ok 17\n"; }
 131 }
 132
 133 #====== need this to make sure error messages come out, even if
 134 #       they were turned off in invoking procedure
 135 sub do_a_perl {
 136     local *P;
 137     open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing');
 138     print P "\$ set message/facil/sever/ident/text\n";
 139     print P "\$ $Invoke_Perl @_\n";
 140     close P;
 141     my $x = `\@vmsish_test.com`;
 142     unlink 'vmsish_test.com';
 143     return $x;
 144 }
 145