Well, it was simple, works, and is orthogonal to the piping code, so
here it is. After patching, the default behavior is unixish: there's a
$STATUS value set when Perl exits, but no message generated.
But do a:
use vmsish 'messages'; (or 'message')
and you'll see the usual %SYSTEM-F-ABORT, when you 'exit 1' (or exit 44)
Note that this only affects the "main" perl exit; if exit() is called
elsewhere, you'll get vmsish behavior. For example, there's many
"this is really fatal so die right now" exit()'s in the vms.c code
that are unaffected by the change. Those however are exit()'s one
*hopefully* never takes.
The patch is to:
perl.h
vms/vmsish.h
lib/vmsish.pm
t/lib/vmsish.t
--- perl.h-orig Thu Mar 9 02:15:46 2000
+++ perl.h Thu Mar 9 02:15:38 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_MESSAGES
+? 0 : 0x10000000))
# define STATUS_NATIVE_SET(n) \
STMT_START { \
PL_statusvalue_vms = (n); \
--- lib/vmsish.pm-orig Thu Mar 9 01:41:34 2000
+++ lib/vmsish.pm Thu Mar 9 01:41:28 2000
@@ -11,6 +11,7 @@
use vmsish 'status'; # or '$?'
use vmsish 'exit';
use vmsish 'time';
+ use vmsish 'messages';
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 messages>
+
+This makes Perl print 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 'message' || $sememe eq 'messages';
$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 messages));
}
sub unimport {
shift;
- $^H &= ~ bits(@_ ? @_ : qw(status exit time));
+ $^H &= ~ bits(@_ ? @_ : qw(status exit time messages));
}
1;
--- t/lib/vmsish.t-orig Thu Mar 9 03:39:21 2000
+++ t/lib/vmsish.t Thu Mar 9 03:39:53 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,10 @@
else { print "ok 6\n"; }
}
-#========== vmsish exit ==========
+#========== vmsish exit, messages ==========
{
use vmsish qw(status);
- my $msg = `$Invoke_Perl "-I[-.lib]" -e "exit 1"`;
+ my $msg = `$Invoke_Perl -e "use vmsish qw(messages); 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 +42,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 = `$Invoke_Perl -e "use vmsish qw(exit messages); 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 +51,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 = `$Invoke_Perl -e "use vmsish qw(exit messages); 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 +59,14 @@
else { print "ok 11\n"; }
if ($? & 1) { print "not ok 12 # subprocess VMS status: $?\n"; }
else { print "ok 12\n"; }
+
+ $msg = `$Invoke_Perl -e "use vmsish qw(exit); 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 +101,31 @@
# 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"; }
}
+
--- vms/vmsish.h-orig Thu Mar 9 01:37:19 2000
+++ vms/vmsish.h Thu Mar 9 01:37:12 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_MESSAGES 0x10000000 /* print 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_MESSAGES TEST_VMSISH(HINT_M_VMSISH_MESSAGES)
#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)
--
Drexel University \V --Chuck Lane
----------------->--------*------------<[EMAIL PROTECTED]
(215) 895-1545 / \ Particle Physics [EMAIL PROTECTED]
FAX: (215) 895-5934 /~~~~~~~~~~~ [EMAIL PROTECTED]
