support for C<use vmsish 'hushed'>; move VMSISH_EXIT out of

op_private (from Charles Lane <lane@DUPHY4.Physics.Drexel.Edu>)

p4raw-id: //depot/perl@5816

3 files changed, 66 insertions, 22 deletions

diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm
index dfb565b326..2fc48530c0 100644
--- a/vms/ext/vmsish.pm
+++ b/vms/ext/vmsish.pm
@@ -11,6 +11,7 @@ vmsish - Perl pragma to control VMS-specific language features
     use vmsish 'status';	# or '$?'
     use vmsish 'exit';
     use vmsish 'time';
+    use vmsish 'hushed';
 
     use vmsish;
     no vmsish 'time';
@@ -18,8 +19,8 @@ vmsish - Perl pragma to control VMS-specific language features
 =head1 DESCRIPTION
 
 If no import list is supplied, all possible VMS-specific features are
-assumed.  Currently, there are three VMS-specific features available:
-'status' (a.k.a '$?'), 'exit', and 'time'.
+assumed.  Currently, there are four VMS-specific features available:
+'status' (a.k.a '$?'), 'exit', 'time' and 'hushed'.
 
 =over 6
 
@@ -41,6 +42,16 @@ used directly as Perl's exit status.
 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 supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR
+if Perl terminates with an error status.  This primarily effects error
+exits from things like compiler errors or "standard Perl" runtime errors,
+where text error messages are also generated by Perl.
+
+The error exits from inside VMS.C are generally more serious, and are
+not supressed.
+
 =back
 
 See L<perlmod/Pragmatic Modules>.
@@ -56,8 +67,8 @@ sub bits {
     my $bits = 0;
     my $sememe;
     foreach $sememe (@_) {
-	$bits |= 0x20000000, next if $sememe eq 'status' || $sememe eq '$?';
-	$bits |= 0x40000000, next if $sememe eq 'exit';
+        $bits |= 0x20000000, next if $sememe eq 'hushed';
+        $bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
 	$bits |= 0x80000000, next if $sememe eq 'time';
     }
     $bits;
@@ -65,12 +76,22 @@ sub bits {
 
 sub import {
     shift;
-    $^H |= bits(@_ ? @_ : qw(status exit time));
+    $^H |= bits(@_ ? @_ : qw(status time hushed));
+    my $sememe;
+
+    foreach $sememe (@_ ? @_ : qw(exit)) {
+        $^H{'vmsish_exit'}   = 1 if $sememe eq 'exit';
+    }
 }
 
 sub unimport {
     shift;
-    $^H &= ~ bits(@_ ? @_ : qw(status exit time));
+    $^H &= ~ bits(@_ ? @_ : qw(status time hushed));
+    my $sememe;
+
+    foreach $sememe (@_ ? @_ : qw(exit)) {
+        $^H{'vmsish_exit'}   = 0 if $sememe eq 'exit';
+    }
 }
 
 1;
diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t
index 24a9f437ef..2a5b580bda 100644
--- a/vms/ext/vmsish.t
+++ b/vms/ext/vmsish.t
@@ -3,7 +3,7 @@ BEGIN { unshift @INC, '[-.lib]'; }
 
 my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
 
-print "1..16\n";
+print "1..17\n";
 
 #========== vmsish status ==========
 `$Invoke_Perl -e 1`;  # Avoid system() from a pipe from harness.  Mutter.
@@ -30,10 +30,11 @@ else    { print "ok 5\n";                          }
   else    { print "ok 6\n"; }
 }
 
-#========== vmsish exit ==========
+#========== vmsish exit, messages ==========
 {
   use vmsish qw(status);
-  my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`;
+
+  $msg = do_a_perl('-e "exit 1"');
   if ($msg !~ /ABORT/) {
     $msg =~ s/\n/\\n/g; # keep output on one line
     print "not ok 7 # subprocess output: |$msg|\n";
@@ -42,7 +43,7 @@ else    { print "ok 5\n";                          }
   if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
   else        { print "ok 8\n"; }
 
-  $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 1"`;
+  $msg = do_a_perl('-e "use vmsish qw(exit); exit 1"');
   if (length $msg) {
     $msg =~ s/\n/\\n/g; # keep output on one line
     print "not ok 9 # subprocess output: |$msg|\n";
@@ -51,7 +52,7 @@ else    { print "ok 5\n";                          }
   if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
   else              { print "ok 10\n"; }
 
-  $msg = `$Invoke_Perl "-I[-.lib]" -e "use vmsish qw(exit); exit 44"`;
+  $msg = do_a_perl('-e "use vmsish qw(exit); exit 44"');
   if ($msg !~ /ABORT/) {
     $msg =~ s/\n/\\n/g; # keep output on one line
     print "not ok 11 # subprocess output: |$msg|\n";
@@ -59,6 +60,14 @@ else    { print "ok 5\n";                          }
   else { print "ok 11\n"; }
   if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
   else        { print "ok 12\n"; }
+
+  $msg = do_a_perl('-e "use vmsish qw(exit hushed); exit 44"');
+  if ($msg =~ /ABORT/) {
+    $msg =~ s/\n/\\n/g; # keep output on one line
+    print "not ok 13 # subprocess output: |$msg|\n";
+  }
+  else { print "ok 13\n"; }
+
 }
 
 
@@ -93,30 +102,44 @@ else    { print "ok 5\n";                          }
   # an amount, and it renders the test resistant to delays from
   # things like stat() on a file mounted over a slow network link.
   if ($utctime - $vmstime + $offset > 10) {
-    print "not ok 13  # (time) UTC: $utctime  VMS: $vmstime\n";
+    print "not ok 14  # (time) UTC: $utctime  VMS: $vmstime\n";
   }
-  else { print "ok 13\n"; }
+  else { print "ok 14\n"; }
 
   $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];
   if ($vmsval - $utcval + $offset > 10) {
-    print "not ok 14  # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
+    print "not ok 15  # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
   }
-  else { print "ok 14\n"; }
+  else { print "ok 15\n"; }
 
   $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];
   if ($vmsval - $utcval + $offset > 10) {
-    print "not ok 15  # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
+    print "not ok 16  # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
   }
-  else { print "ok 15\n"; }
+  else { print "ok 16\n"; }
 
   if ($vmsmtime - $utcmtime + $offset > 10) {
-    print "not ok 16  # (stat) UTC: $utcmtime  VMS: $vmsmtime\n";
+    print "not ok 17  # (stat) UTC: $utcmtime  VMS: $vmsmtime\n";
   }
-  else { print "ok 16\n"; }
+  else { print "ok 17\n"; }
+}
+
+#====== 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 "\$ $Invoke_Perl @_\n";
+    close P;
+    my $x = `\@vmsish_test.com`;
+    unlink 'vmsish_test.com';
+    return $x;
 }
+
diff --git a/vms/vmsish.h b/vms/vmsish.h
index 12b13696ce..e53c604d16 100644
--- a/vms/vmsish.h
+++ b/vms/vmsish.h
@@ -223,14 +223,14 @@
 #define COMPLEX_STATUS	1	/* We track both "POSIX" and VMS values */
 
 #define HINT_V_VMSISH		24
-#define HINT_M_VMSISH_STATUS	0x20000000 /* system, $? return VMS status */
-#define HINT_M_VMSISH_EXIT	0x40000000 /* exit(1) ==> SS$_NORMAL */
+#define HINT_M_VMSISH_HUSHED	0x20000000 /* stifle error msgs on exit */
+#define HINT_M_VMSISH_STATUS	0x40000000 /* system, $? return VMS status */
 #define HINT_M_VMSISH_TIME	0x80000000 /* times are local, not UTC */
 #define NATIVE_HINTS		(PL_hints >> HINT_V_VMSISH)  /* used in op.c */
 
 #define TEST_VMSISH(h)	(PL_curcop->op_private & ((h) >> HINT_V_VMSISH))
+#define VMSISH_HUSHED	TEST_VMSISH(HINT_M_VMSISH_HUSHED)
 #define VMSISH_STATUS	TEST_VMSISH(HINT_M_VMSISH_STATUS)
-#define VMSISH_EXIT	TEST_VMSISH(HINT_M_VMSISH_EXIT)
 #define VMSISH_TIME	TEST_VMSISH(HINT_M_VMSISH_TIME)
 
 /* Flags for vmstrnenv() */