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     BEGIN { $Orig_Bits = $^H }
  17
  18     # make sure that all those 'use vmsish' calls didn't do anything.
  19     is( $Orig_Bits, $^H,    'use vmsish a no-op' );
  20 }
  21
  22 SKIP: {
  23     skip("tests for VMS only", 24) unless $^O eq 'VMS';
  24
  25 #========== vmsish status ==========
  26 `$Invoke_Perl -e 1`;  # Avoid system() from a pipe from harness.  Mutter.
  27 is($?,0,"simple Perl invokation: POSIX success status");
  28 {
  29   use vmsish qw(status);
  30   is(($? & 1),1, "importing vmsish [vmsish status]");
  31   {
  32     no vmsish qw(status); # check unimport function
  33     is($?,0, "unimport vmsish [POSIX STATUS]");
  34   }
  35   # and lexical scoping
  36   is(($? & 1),1,"lex scope of vmsish [vmsish status]");
  37 }
  38 is($?,0,"outer lex scope of vmsish [POSIX status]");
  39
  40 {
  41   use vmsish qw(exit);  # check import function
  42   is($?,0,"importing vmsish exit [POSIX status]");
  43 }
  44
  45 #========== vmsish exit, messages ==========
  46 {
  47   use vmsish qw(status);
  48
  49   $msg = do_a_perl('-e "exit 1"');
  50     $msg =~ s/\n/\\n/g; # keep output on one line
  51   like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
  52   is($?&1,0,"vmsish status check, POSIX ERR exit");
  53
  54   $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
  55     $msg =~ s/\n/\\n/g; # keep output on one line
  56   ok(length($msg)==0,"vmsish OK exit, DCL error message check");
  57   is($?&1,1, "vmsish status check, vmsish OK exit");
  58
  59   $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
  60     $msg =~ s/\n/\\n/g; # keep output on one line
  61   like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
  62   is($?&1,0,"vmsish ERR exit, vmsish status check");
  63
  64   $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
  65   $msg =~ s/\n/\\n/g; # keep output on one line
  66   ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
  67
  68   $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
  69     $msg =~ s/\n/\\n/g; # keep output on one line
  70   ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
  71
  72   $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
  73   $msg =~ s/\n/\\n/g; # keep output on one line
  74   like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
  75
  76   $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
  77   $msg =~ s/\n/\\n/g; # keep output on one line
  78   ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
  79
  80   $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
  81   $msg =~ s/\n/\\n/g; # keep output on one line
  82   ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
  83
  84   $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
  85   $msg =~ s/\n/\\n/g; # keep output on one line
  86   ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
  87
  88   local *TEST;
  89   open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');
  90   print TEST "#! perl\n";
  91   print TEST "use vmsish qw(hushed);\n";
  92   print TEST "\$obvious = (\$compile(\$error;\n";
  93   close TEST;
  94   $msg = do_a_perl('vmsish_test.pl');
  95   $msg =~ s/\n/\\n/g; # keep output on one line
  96   ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
  97   unlink 'vmsish_test.pl';
  98 }
  99
 100
 101 #========== vmsish time ==========
 102 {
 103   my($utctime, @utclocal, @utcgmtime, $utcmtime,
 104      $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
 105      $utcval,  $vmaval, $offset);
 106   # Make sure apparent local time isn't GMT
 107   if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
 108     $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
 109     $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
 110     eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
 111     gmtime(0); # Force reset of tz offset
 112   }
 113   {
 114      use_ok('vmsish qw(time)');
 115      $vmstime   = time;
 116      @vmslocal  = localtime($vmstime);
 117      @vmsgmtime = gmtime($vmstime);
 118      $vmsmtime  = (stat $0)[9];
 119   }
 120   $utctime   = time;
 121   @utclocal  = localtime($vmstime);
 122   @utcgmtime = gmtime($vmstime);
 123   $utcmtime  = (stat $0)[9];
 124
 125   $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
 126
 127   # We allow lots of leeway (10 sec) difference for these tests,
 128   # since it's unlikely local time will differ from UTC by so small
 129   # an amount, and it renders the test resistant to delays from
 130   # things like stat() on a file mounted over a slow network link.
 131   ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime");
 132
 133   $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
 134             $utclocal[2] * 3600     + $utclocal[1] * 60 + $utclocal[0];
 135   $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
 136             $vmslocal[2] * 3600     + $vmslocal[1] * 60 + $vmslocal[0];
 137   ok($vmsval - $utcval + $offset <= 10, "(localtime)");
 138   print "# UTC: @utclocal\n# VMS: @vmslocal\n";
 139
 140   $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
 141             $utcgmtime[2] * 3600     + $utcgmtime[1] * 60 + $utcgmtime[0];
 142   $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
 143             $vmsgmtime[2] * 3600     + $vmsgmtime[1] * 60 + $vmsgmtime[0];
 144   ok($vmsval - $utcval + $offset <= 10, "(gmtime)");
 145   print "# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
 146
 147   ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime  VMS: $vmsmtime");
 148 }
 149 }
 150
 151 #====== need this to make sure error messages come out, even if
 152 #       they were turned off in invoking procedure
 153 sub do_a_perl {
 154     local *P;
 155     open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing');
 156     print P "\$ set message/facil/sever/ident/text\n";
 157     print P "\$ define/nolog/user sys\$error _nla0:\n";
 158     print P "\$ $Invoke_Perl @_\n";
 159     close P;
 160     my $x = `\@vmsish_test.com`;
 161     unlink 'vmsish_test.com';
 162     return $x;
 163 }
 164