diff options
Diffstat (limited to 'vms')
| -rw-r--r-- | vms/ext/vmsish.pm | 15 | ||||
| -rw-r--r-- | vms/ext/vmsish.t | 49 | ||||
| -rw-r--r-- | vms/test.com | 1 | ||||
| -rw-r--r-- | vms/vmsish.h | 2 |
4 files changed, 50 insertions, 17 deletions
diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm index dfb565b326..a0e6e3cc21 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<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 @@ 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 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/test.com b/vms/test.com index bda5f7d07e..5bb999d5a4 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 12b13696ce..e460241ba1 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) |