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

12 files changed, 91 insertions, 27 deletions

diff --git a/embed.pl b/embed.pl
index 0593f0403a..c8eb0a5cb4 100755
--- a/embed.pl
+++ b/embed.pl
@@ -870,6 +870,7 @@ print CAPIH <<'EOT';
 #endif /* __perlapi_h__ */
 
 EOT
+close CAPIH;
 
 print CAPI <<'EOT';
 /* !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
diff --git a/op.c b/op.c
index 97d2e4b7f6..d2289847e8 100644
--- a/op.c
+++ b/op.c
@@ -5163,6 +5163,20 @@ Perl_ck_eval(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_exit(pTHX_ OP *o)
+{
+#ifdef VMS
+    HV *table = GvHV(PL_hintgv);
+    if (table) {
+       SV **svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
+       if (svp && *svp && SvTRUE(*svp))
+           o->op_private |= OPpEXIT_VMSISH;
+    }
+#endif
+    return ck_fun(o);
+}
+
+OP *
 Perl_ck_exec(pTHX_ OP *o)
 {
     OP *kid;
diff --git a/op.h b/op.h
index 827b0803aa..081d10c0e8 100644
--- a/op.h
+++ b/op.h
@@ -203,6 +203,9 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpOPEN_OUT_RAW		64	/* binmode(F,":raw") on output fh */
 #define OPpOPEN_OUT_CRLF	128	/* binmode(F,":crlf") on output fh */
 
+/* Private for OP_EXIT */
+#define OPpEXIT_VMSISH		128	/* exit(0) vs. exit(1) vmsish mode*/
+
 struct op {
     BASEOP
 };
diff --git a/opcode.h b/opcode.h
index 7ff516b5aa..f0fcba9fef 100644
--- a/opcode.h
+++ b/opcode.h
@@ -1284,7 +1284,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = {
 	MEMBER_TO_FPTR(Perl_ck_null),	/* redo */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* dump */
 	MEMBER_TO_FPTR(Perl_ck_null),	/* goto */
-	MEMBER_TO_FPTR(Perl_ck_fun),	/* exit */
+	MEMBER_TO_FPTR(Perl_ck_exit),	/* exit */
 	MEMBER_TO_FPTR(Perl_ck_open),	/* open */
 	MEMBER_TO_FPTR(Perl_ck_fun),	/* close */
 	MEMBER_TO_FPTR(Perl_ck_fun),	/* pipe_op */
diff --git a/opcode.pl b/opcode.pl
index fc661caaf4..eb64e8dc14 100755
--- a/opcode.pl
+++ b/opcode.pl
@@ -597,7 +597,7 @@ next		next			ck_null		ds}
 redo		redo			ck_null		ds}	
 dump		dump			ck_null		ds}	
 goto		goto			ck_null		ds}	
-exit		exit			ck_fun		ds%	S?
+exit		exit			ck_exit		ds%	S?
 # continued below
 
 #nswitch	numeric switch		ck_null		d	
diff --git a/perl.h b/perl.h
index 2b4465c601..2f30218978 100644
--- a/perl.h
+++ b/perl.h
@@ -1652,7 +1652,7 @@ typedef pthread_key_t	perl_key;
 #ifdef VMS
 #   define STATUS_NATIVE	PL_statusvalue_vms
 #   define STATUS_NATIVE_EXPORT \
-	((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms)
+	(((I32)PL_statusvalue_vms == -1 ? 44 : PL_statusvalue_vms) | (VMSISH_HUSHED ? 0x10000000 : 0))
 #   define STATUS_NATIVE_SET(n)						\
 	STMT_START {							\
 	    PL_statusvalue_vms = (n);					\
diff --git a/pp.sym b/pp.sym
index 73d3dcfba6..0e6c056611 100644
--- a/pp.sym
+++ b/pp.sym
@@ -13,6 +13,7 @@ Perl_ck_eof
 Perl_ck_eval
 Perl_ck_exec
 Perl_ck_exists
+Perl_ck_exit
 Perl_ck_ftst
 Perl_ck_fun
 Perl_ck_fun_locale
diff --git a/pp_ctl.c b/pp_ctl.c
index cee753a125..00fa47673a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2463,8 +2463,8 @@ PP(pp_exit)
 	anum = 0;
     else {
 	anum = SvIVx(POPs);
-#ifdef VMSISH_EXIT
-	if (anum == 1 && VMSISH_EXIT)
+#ifdef VMS
+        if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
 	    anum = 0;
 #endif
     }
diff --git a/pp_proto.h b/pp_proto.h
index 7f2d80b0b1..4ce9d74594 100644
--- a/pp_proto.h
+++ b/pp_proto.h
@@ -12,6 +12,7 @@ PERL_CKDEF(Perl_ck_eof)
 PERL_CKDEF(Perl_ck_eval)
 PERL_CKDEF(Perl_ck_exec)
 PERL_CKDEF(Perl_ck_exists)
+PERL_CKDEF(Perl_ck_exit)
 PERL_CKDEF(Perl_ck_ftst)
 PERL_CKDEF(Perl_ck_fun)
 PERL_CKDEF(Perl_ck_fun_locale)
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() */