diff options
| -rwxr-xr-x | embed.pl | 1 | ||||
| -rw-r--r-- | op.c | 14 | ||||
| -rw-r--r-- | op.h | 3 | ||||
| -rw-r--r-- | opcode.h | 2 | ||||
| -rwxr-xr-x | opcode.pl | 2 | ||||
| -rw-r--r-- | perl.h | 2 | ||||
| -rw-r--r-- | pp.sym | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 4 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rw-r--r-- | vms/ext/vmsish.pm | 33 | ||||
| -rw-r--r-- | vms/ext/vmsish.t | 49 | ||||
| -rw-r--r-- | vms/vmsish.h | 6 |
12 files changed, 91 insertions, 27 deletions
@@ -870,6 +870,7 @@ print CAPIH <<'EOT'; #endif /* __perlapi_h__ */ EOT +close CAPIH; print CAPI <<'EOT'; /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!! @@ -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; @@ -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 }; @@ -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 */ @@ -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 @@ -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); \ @@ -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 @@ -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() */ |