Thanks for the great feedback, guys. I looked up an online thesaurus
(what's another word for thesaurus, hmm?) and found what seems like
an acceptable keyword:
use vmsish 'hushed';
Default is "off" (i.e, print the error messages). I'm also including
a patch to TEST.COM to use "SET MESSAGE/NOFACIL/ etc" for testing.
Because SET MESSAGE is propagated to subprocesses by LIB$SPAWN,
it's a bit difficult to turn messages on again for testing by
vmsish.t...we get around that by writing and executing a command
procedure with a SET MESSAGE and a Perl command.
Patch follows:
--- perl.h-orig Fri Mar 10 15:57:21 2000
+++ perl.h Fri Mar 10 21:53:33 2000
@@ -1642,7 +1642,7 @@
#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); \
--- vms/test.com-orig Fri Mar 10 15:57:23 2000
+++ vms/test.com Fri Mar 10 22:02:56 2000
@@ -94,6 +94,7 @@
$ Show Process/Accounting
$ testdir = "Directory/NoHead/NoTrail/Column=1"
$ Define/User 'dbg'Perlshr Sys$Disk:[-]'dbg'PerlShr'exe'
+$ set message/nofacil/nosever/noiden/notext
$ MCR Sys$Disk:[]Perl. "-I[-.lib]" - "''p3'" "''p4'" "''p5'" "''p6'"
$ Deck/Dollar=$$END-OF-TEST$$
# $RCSfile: TEST,v $$Revision: 4.1 $$Date: 92/08/07 18:27:00 $
--- vms/vmsish.h-orig Fri Mar 10 15:57:23 2000
+++ vms/vmsish.h Fri Mar 10 21:54:41 2000
@@ -223,12 +223,14 @@
#define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */
#define HINT_V_VMSISH 24
+#define HINT_M_VMSISH_HUSHED 0x10000000 /* turn off message on error exit*/
#define HINT_M_VMSISH_STATUS 0x20000000 /* system, $? return VMS status */
#define HINT_M_VMSISH_EXIT 0x40000000 /* exit(1) ==> SS$_NORMAL */
#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)
--- vms/ext/vmsish.pm-orig Fri Mar 10 15:57:23 2000
+++ vms/ext/vmsish.pm Fri Mar 10 21:57:00 2000
@@ -11,6 +11,7 @@
use vmsish 'status'; # or '$?'
use vmsish 'exit';
use vmsish 'time';
+ use vmsish 'hushed';
use vmsish;
no vmsish 'time';
@@ -18,8 +19,8 @@
=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 'messages' (a.k.a 'message').
=over 6
@@ -41,6 +42,11 @@
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.
+
=back
See L<perlmod/Pragmatic Modules>.
@@ -56,6 +62,7 @@
my $bits = 0;
my $sememe;
foreach $sememe (@_) {
+ $bits |= 0x10000000, next if $sememe eq 'hushed';
$bits |= 0x20000000, next if $sememe eq 'status' || $sememe eq '$?';
$bits |= 0x40000000, next if $sememe eq 'exit';
$bits |= 0x80000000, next if $sememe eq 'time';
@@ -65,12 +72,12 @@
sub import {
shift;
- $^H |= bits(@_ ? @_ : qw(status exit time));
+ $^H |= bits(@_ ? @_ : qw(status exit time hushed));
}
sub unimport {
shift;
- $^H &= ~ bits(@_ ? @_ : qw(status exit time));
+ $^H &= ~ bits(@_ ? @_ : qw(status exit time hushed));
}
1;
--- vms/ext/vmsish.t-orig Fri Mar 10 15:57:24 2000
+++ vms/ext/vmsish.t Sat Mar 11 00:10:24 2000
@@ -3,7 +3,7 @@
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 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 @@
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 @@
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 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 @@
# 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;
}
+
--
Drexel University \V --Chuck Lane
----------------->--------*------------<[EMAIL PROTECTED]
(215) 895-1545 / \ Particle Physics [EMAIL PROTECTED]
FAX: (215) 895-5934 /~~~~~~~~~~~ [EMAIL PROTECTED]
