#endif /* __perlapi_h__ */
EOT
+close CAPIH;
print CAPI <<'EOT';
/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
}
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;
#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
};
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 */
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
#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); \
Perl_ck_eval
Perl_ck_exec
Perl_ck_exists
+Perl_ck_exit
Perl_ck_ftst
Perl_ck_fun
Perl_ck_fun_locale
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
}
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)
use vmsish 'status'; # or '$?'
use vmsish 'exit';
use vmsish 'time';
+ use vmsish 'hushed';
use vmsish;
no vmsish 'time';
=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
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>.
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;
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;
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.
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";
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";
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";
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"; }
+
}
# 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;
}
+
#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() */
projects / p5sagit/p5-mst-13.2.git / commitdiff