vms/ext/vmsish.t

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