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