From: Charles Bailey Date: Mon, 13 Mar 2000 03:00:16 +0000 (+0000) Subject: Add vmsish 'hushed' option to suppress error messages at exit X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=925fd5a3f200998584b0c9f5f508f038863055cb;p=p5sagit%2Fp5-mst-13.2.git Add vmsish 'hushed' option to suppress error messages at exit p4raw-id: //depot/vmsperl@5693 --- diff --git a/perl.h b/perl.h index d4d2292..19a65a0 100644 --- a/perl.h +++ b/perl.h @@ -1645,7 +1645,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/vms/ext/vmsish.pm b/vms/ext/vmsish.pm index dfb565b..a0e6e3c 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 'messages' (a.k.a 'message'). =over 6 @@ -41,6 +42,11 @@ 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 + +This supresses printing of VMS status messages to SYS$OUTPUT and SYS$ERROR +if Perl terminates with an error status. + =back See L. @@ -56,6 +62,7 @@ sub bits { 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 bits { 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; diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index 24a9f43..2a5b580 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/test.com b/vms/test.com index bda5f7d..5bb999d 100644 --- a/vms/test.com +++ b/vms/test.com @@ -94,6 +94,7 @@ $! And do it $ 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 $ diff --git a/vms/vmsish.h b/vms/vmsish.h index 12b1369..e460241 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -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)