Making vmsish.pm a no-op on non-VMS

Message-ID: <20011112205034.H2888@blackrider>

p4raw-id: //depot/perl@12971

2 files changed, 0 insertions, 292 deletions

diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm
deleted file mode 100644
index 89ec72c28c..0000000000
--- a/vms/ext/vmsish.pm
+++ /dev/null
@@ -1,147 +0,0 @@
-package vmsish;
-
-=head1 NAME
-
-vmsish - Perl pragma to control VMS-specific language features
-
-=head1 SYNOPSIS
-
-    use vmsish;
-
-    use vmsish 'status';	# or '$?'
-    use vmsish 'exit';
-    use vmsish 'time';
-
-    use vmsish 'hushed';
-    no vmsish 'hushed';
-    vmsish::hushed($hush);
-
-    use vmsish;
-    no vmsish 'time';
-
-=head1 DESCRIPTION
-
-If no import list is supplied, all possible VMS-specific features are
-assumed.  Currently, there are four VMS-specific features available:
-'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'.
-
-=over 6
-
-=item C<vmsish status>
-
-This makes C<$?> and C<system> return the native VMS exit status
-instead of emulating the POSIX exit status.
-
-=item C<vmsish exit>
-
-This makes C<exit 1> produce a successful exit (with status SS$_NORMAL),
-instead of emulating UNIX exit(), which considers C<exit 1> to indicate
-an error.  As with the CRTL's exit() function, C<exit 0> is also mapped
-to an exit status of SS$_NORMAL, and any other argument to exit() is
-used directly as Perl's exit status.
-
-=item C<vmsish time>
-
-This makes all times relative to the local time zone, instead of the
-default of Universal Time (a.k.a Greenwich Mean Time, or GMT).
-
-=item C<vmsish hushed>
-
-This suppresses printing of VMS status messages to SYS$OUTPUT and
-SYS$ERROR if Perl terminates with an error status.  and allows
-programs that are expecting "unix-style" Perl to avoid having to parse
-VMS error messages.  It does not supress any messages from Perl
-itself, just the messages generated by DCL after Perl exits.  The DCL
-symbol $STATUS will still have the termination status, but with a
-high-order bit set:
-
-EXAMPLE:
-    $ perl -e"exit 44;"                             Non-hushed error exit
-    %SYSTEM-F-ABORT, abort                          DCL message
-    $ show sym $STATUS
-      $STATUS == "%X0000002C"
-
-    $ perl -e"use vmsish qw(hushed); exit 44;"      Hushed error exit
-    $ show sym $STATUS
-      $STATUS == "%X1000002C"
-
-The 'hushed' flag has a global scope during compilation: the exit() or
-die() commands that are compiled after 'vmsish hushed' will be hushed
-when they are executed.  Doing a "no vmsish 'hushed'" turns off the
-hushed flag.
-
-The status of the hushed flag also affects output of VMS error
-messages from compilation errors.   Again, you still get the Perl
-error message (and the code in $STATUS)
-
-EXAMPLE:
-    use vmsish 'hushed';    # turn on hushed flag
-    use Carp;          # Carp compiled hushed
-    exit 44;           # will be hushed
-    croak('I die');    # will be hushed
-    no vmsish 'hushed';     # turn off hushed flag
-    exit 44;           # will not be hushed
-    croak('I die2'):   # WILL be hushed, croak was compiled hushed
-
-You can also control the 'hushed' flag at run-time, using the built-in
-routine vmsish::hushed().  Without argument, it returns the hushed status.
-Since vmsish::hushed is built-in, you do not need to "use vmsish" to call
-it.
-
-EXAMPLE:
-    if ($quiet_exit) {
-        vmsish::hushed(1);
-    } 
-    print "Sssshhhh...I'm hushed...\n" if vmsish::hushed();
-    exit 44;
-
-Note that an exit() or die() that is compiled 'hushed' because of "use
-vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime.
-
-The messages from error exits from inside the Perl core are generally
-more serious, and are not supressed.
-
-=back
-
-See L<perlmod/Pragmatic Modules>.
-
-=cut
-
-if ($^O ne 'VMS') {
-    require Carp;
-    Carp::croak("This isn't VMS");
-}
-
-sub bits {
-    my $bits = 0;
-    my $sememe;
-    foreach $sememe (@_) {
-        $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
-	$bits |= 0x80000000, next if $sememe eq 'time';
-    }
-    $bits;
-}
-
-sub import {
-    shift;
-    $^H |= bits(@_ ? @_ : qw(status time));
-    my $sememe;
-
-    foreach $sememe (@_ ? @_ : qw(exit hushed)) {
-        $^H{'vmsish_exit'}   = 1 if $sememe eq 'exit';
-        vmsish::hushed(1) if $sememe eq 'hushed';
-    }
-}
-
-sub unimport {
-    shift;
-    $^H &= ~ bits(@_ ? @_ : qw(status time));
-    my $sememe;
-
-    foreach $sememe (@_ ? @_ : qw(exit hushed)) {
-        $^H{'vmsish_exit'}   = 0 if $sememe eq 'exit';
-        vmsish::hushed(0) if $sememe eq 'hushed';
-    }
-}
-
-1;
diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t
deleted file mode 100644
index 0f3c0ec1eb..0000000000
--- a/vms/ext/vmsish.t
+++ /dev/null
@@ -1,145 +0,0 @@
-
-BEGIN { unshift @INC, '[-.lib]'; }
-
-my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
-
-require "test.pl";
-plan(tests => 24);
-
-#========== vmsish status ==========
-`$Invoke_Perl -e 1`;  # Avoid system() from a pipe from harness.  Mutter.
-is($?,0,"simple Perl invokation: POSIX success status");
-{
-  use vmsish qw(status);
-  is(($? & 1),1, "importing vmsish [vmsish status]");
-  {
-    no vmsish qw(status); # check unimport function
-    is($?,0, "unimport vmsish [POSIX STATUS]");
-  }
-  # and lexical scoping
-  is(($? & 1),1,"lex scope of vmsish [vmsish status]");
-}
-is($?,0,"outer lex scope of vmsish [POSIX status]");
-
-{
-  use vmsish qw(exit);  # check import function
-  is($?,0,"importing vmsish exit [POSIX status]");
-}
-
-#========== vmsish exit, messages ==========
-{
-  use vmsish qw(status);
-
-  $msg = do_a_perl('-e "exit 1"');
-    $msg =~ s/\n/\\n/g; # keep output on one line
-  like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
-  is($?&1,0,"vmsish status check, POSIX ERR exit");
-
-  $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
-    $msg =~ s/\n/\\n/g; # keep output on one line
-  ok(length($msg)==0,"vmsish OK exit, DCL error message check");
-  is($?&1,1, "vmsish status check, vmsish OK exit");
-
-  $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
-    $msg =~ s/\n/\\n/g; # keep output on one line
-  like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
-  is($?&1,0,"vmsish ERR exit, vmsish status check");
-
-  $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
-  $msg =~ s/\n/\\n/g; # keep output on one line
-  ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
-
-  $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
-    $msg =~ s/\n/\\n/g; # keep output on one line
-  ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
-
-  $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
-  $msg =~ s/\n/\\n/g; # keep output on one line
-  like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
-
-  $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
-  $msg =~ s/\n/\\n/g; # keep output on one line
-  ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
-
-  $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
-  $msg =~ s/\n/\\n/g; # keep output on one line
-  ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
-
-  $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
-  $msg =~ s/\n/\\n/g; # keep output on one line
-  ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
-
-  local *TEST;
-  open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');  
-  print TEST "#! perl\n";
-  print TEST "use vmsish qw(hushed);\n";
-  print TEST "\$obvious = (\$compile(\$error;\n";
-  close TEST;
-  $msg = do_a_perl('vmsish_test.pl');
-  $msg =~ s/\n/\\n/g; # keep output on one line
-  ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
-  unlink 'vmsish_test.pl';
-}
-
-
-#========== vmsish time ==========
-{
-  my($utctime, @utclocal, @utcgmtime, $utcmtime,
-     $vmstime, @vmslocal, @vmsgmtime, $vmsmtime,
-     $utcval,  $vmaval, $offset);
-  # Make sure apparent local time isn't GMT
-  if (not $ENV{'SYS$TIMEZONE_DIFFERENTIAL'}) {
-    $oldtz = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
-    $ENV{'SYS$TIMEZONE_DIFFERENTIAL'} = 3600;
-    eval "END { \$ENV{'SYS\$TIMEZONE_DIFFERENTIAL'} = $oldtz; }";
-    gmtime(0); # Force reset of tz offset
-  }
-  {
-     use_ok('vmsish qw(time)');
-     $vmstime   = time;
-     @vmslocal  = localtime($vmstime);
-     @vmsgmtime = gmtime($vmstime);
-     $vmsmtime  = (stat $0)[9];
-  }
-  $utctime   = time;
-  @utclocal  = localtime($vmstime);
-  @utcgmtime = gmtime($vmstime);
-  $utcmtime  = (stat $0)[9];
-  
-  $offset = $ENV{'SYS$TIMEZONE_DIFFERENTIAL'};
-
-  # We allow lots of leeway (10 sec) difference for these tests,
-  # since it's unlikely local time will differ from UTC by so small
-  # an amount, and it renders the test resistant to delays from
-  # things like stat() on a file mounted over a slow network link.
-  ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime");
-
-  $utcval = $utclocal[5] * 31536000 + $utclocal[7] * 86400 +
-            $utclocal[2] * 3600     + $utclocal[1] * 60 + $utclocal[0];
-  $vmsval = $vmslocal[5] * 31536000 + $vmslocal[7] * 86400 +
-            $vmslocal[2] * 3600     + $vmslocal[1] * 60 + $vmslocal[0];
-  ok($vmsval - $utcval + $offset <= 10, "(localtime)\n# UTC: @utclocal\n# VMS: @vmslocal");
-
-  $utcval = $utcgmtime[5] * 31536000 + $utcgmtime[7] * 86400 +
-            $utcgmtime[2] * 3600     + $utcgmtime[1] * 60 + $utcgmtime[0];
-  $vmsval = $vmsgmtime[5] * 31536000 + $vmsgmtime[7] * 86400 +
-            $vmsgmtime[2] * 3600     + $vmsgmtime[1] * 60 + $vmsgmtime[0];
-  ok($vmsval - $utcval + $offset <= 10, "(gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime");
-
-  ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime  VMS: $vmsmtime");
-}
-
-#====== need this to make sure error messages come out, even if
-#       they were turned off in invoking procedure
-sub do_a_perl {
-    local *P;
-    open(P,'>vmsish_test.com') || die('not ok ?? : unable to open "vmsish_test.com" for writing');
-    print P "\$ set message/facil/sever/ident/text\n";
-    print P "\$ define/nolog/user sys\$error _nla0:\n";
-    print P "\$ $Invoke_Perl @_\n";
-    close P;
-    my $x = `\@vmsish_test.com`;
-    unlink 'vmsish_test.com';
-    return $x;
-}
-