lib/vmsish.t

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