$! Check rand48 and its ilk
$!
$ echo4 "Looking for a random number function..."
-$ d_use_rand = "undef"
$ OS
$ WS "#if defined(__DECC) || defined(__DECCXX)"
$ WS "#include <stdlib.h>"
$ THEN
$ echo4 "OK, found random()."
$ ELSE
-$ drand01="(((float)rand())*PL_my_inv_rand_max)"
+$ drand01="(((float)rand())*MY_INV_RAND_MAX)"
$ randseedtype = "unsigned"
$ seedfunc = "srand"
-$ d_use_rand = "define"
$ echo4 "Yick, looks like I have to use rand()."
$ ENDIF
$ ENDIF
$! Alas this does not help to build Fcntl
$! WC "#define PERL_IGNORE_FPUSIG SIGFPE"
$ ENDIF
-$ if d_use_rand .EQS. "define" then WC "#define Drand01_is_rand"
$ CLOSE CONFIG
$!
$ echo4 "Doing variable substitutions on .SH files..."
}
else if (o->op_type == OP_EXIT) {
if (o->op_private & OPpEXIT_VMSISH)
- sv_catpv(tmpsv, ",EXIST_VMSISH");
+ sv_catpv(tmpsv, ",EXIT_VMSISH");
+ if (o->op_private & OPpHUSH_VMSISH)
+ sv_catpv(tmpsv, ",HUSH_VMSISH");
+ }
+ else if (o->op_type == OP_DIE) {
+ if (o->op_private & OPpHUSH_VMSISH)
+ sv_catpv(tmpsv, ",HUSH_VMSISH");
}
if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
sv_catpv(tmpsv, ",INTRO");
if ($Is_VMS) {
$a =~ s/-uFile,-uFile::Copy,//;
$a =~ s/-uVMS,-uVMS::Filespec,//;
+ $a =~ s/-uvmsish,//;
$a =~ s/-uSocket,//; # Socket is optional/compiler version dependent
}
}
OP *
+Perl_ck_die(pTHX_ OP *o)
+{
+#ifdef VMS
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
+#endif
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_eof(pTHX_ OP *o)
{
I32 type = o->op_type;
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
#endif
return ck_fun(o);
}
#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 */
+/* Private for OP_EXIT, HUSH also for OP_DIE */
+#define OPpHUSH_VMSISH 64 /* hush DCL exit msg vmsish mode*/
#define OPpEXIT_VMSISH 128 /* exit(0) vs. exit(1) vmsish mode*/
struct op {
MEMBER_TO_FPTR(Perl_ck_null), /* leavesublv */
MEMBER_TO_FPTR(Perl_ck_fun), /* caller */
MEMBER_TO_FPTR(Perl_ck_fun), /* warn */
- MEMBER_TO_FPTR(Perl_ck_fun), /* die */
+ MEMBER_TO_FPTR(Perl_ck_die), /* die */
MEMBER_TO_FPTR(Perl_ck_fun), /* reset */
MEMBER_TO_FPTR(Perl_ck_null), /* lineseq */
MEMBER_TO_FPTR(Perl_ck_null), /* nextstate */
leavesublv lvalue subroutine return ck_null 1
caller caller ck_fun t% S?
warn warn ck_fun imst@ L
-die die ck_fun dimst@ L
+die die ck_die dimst@ L
reset symbol reset ck_fun is% S?
lineseq line sequence ck_null @
#endif
oldscope = PL_scopestack_ix;
+#ifdef VMS
+ VMSISH_HUSHED = 0;
+#endif
#ifdef PERL_FLEXIBLE_EXCEPTIONS
redo_body:
# define MYSWAP
#endif
-#if !defined(PERL_FOR_X2P) && !defined(WIN32)
+#if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS))
# include "embed.h"
#endif
#else
# if defined(VMS)
# include "vmsish.h"
+# include "embed.h"
# else
# if defined(PLAN9)
# include "./plan9/plan9ish.h"
PERLVAR(Gsharedsv_space, PerlInterpreter*) /* The shared sv space */
PERLVAR(Gsharedsv_space_mutex, perl_mutex) /* Mutex protecting the shared sv space */
#endif
-
-#if defined(VMS) && defined(Drand01_is_rand)
-PERLVAR(Gmy_inv_rand_max, float) /* nasty compiler bug workaround */
-#endif
Perl_ck_concat
Perl_ck_defined
Perl_ck_delete
+Perl_ck_die
Perl_ck_eof
Perl_ck_eval
Perl_ck_exec
#ifdef VMS
if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
anum = 0;
+ VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
#endif
}
PL_exit_flags |= PERL_EXIT_EXPECTED;
PERL_CKDEF(Perl_ck_concat)
PERL_CKDEF(Perl_ck_defined)
PERL_CKDEF(Perl_ck_delete)
+PERL_CKDEF(Perl_ck_die)
PERL_CKDEF(Perl_ck_eof)
PERL_CKDEF(Perl_ck_eval)
PERL_CKDEF(Perl_ck_exec)
SV *tmpsv;
STRLEN len;
bool multiarg = 0;
+#ifdef VMS
+ VMSISH_HUSHED = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
+#endif
if (SP - MARK != 1) {
dTARGET;
do_join(TARG, &PL_sv_no, MARK, SP);
use vmsish 'status'; # or '$?'
use vmsish 'exit';
use vmsish 'time';
+
use vmsish 'hushed';
+ no vmsish 'hushed';
+ vmsish::hushed($hush);
use vmsish;
no vmsish 'time';
=item C<vmsish hushed>
-This suppresses 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 Perl compiler errors or "standard Perl" runtime errors,
-where text error messages are also generated by Perl.
-
-The error exits from inside the core are generally more serious, and are
-not supressed.
+This suppresses printing of VMS status messages to SYS$OUTPUT and
+SYS$ERROR if Perl terminates with an error status. and allows
+programs that are expecting "unix-style" Perl to avoid having to parse
+VMS error messages. It does not supress any messages from Perl
+itself, just the messages generated by DCL after Perl exits. The DCL
+symbol $STATUS will still have the termination status, but with a
+high-order bit set:
+
+EXAMPLE:
+ $ perl -e"exit 44;" Non-hushed error exit
+ %SYSTEM-F-ABORT, abort DCL message
+ $ show sym $STATUS
+ $STATUS == "%X0000002C"
+
+ $ perl -e"use vmsish qw(hushed); exit 44;" Hushed error exit
+ $ show sym $STATUS
+ $STATUS == "%X1000002C"
+
+The 'hushed' flag has a global scope during compilation: the exit() or
+die() commands that are compiled after 'vmsish hushed' will be hushed
+when they are executed. Doing a "no vmsish 'hushed'" turns off the
+hushed flag.
+
+The status of the hushed flag also affects output of VMS error
+messages from compilation errors. Again, you still get the Perl
+error message (and the code in $STATUS)
+
+EXAMPLE:
+ use vmsish 'hushed'; # turn on hushed flag
+ use Carp; # Carp compiled hushed
+ exit 44; # will be hushed
+ croak('I die'); # will be hushed
+ no vmsish 'hushed'; # turn off hushed flag
+ exit 44; # will not be hushed
+ croak('I die2'): # WILL be hushed, croak was compiled hushed
+
+You can also control the 'hushed' flag at run-time, using the built-in
+routine vmsish::hushed(). Without argument, it returns the hushed status.
+Since vmsish::hushed is built-in, you do not need to "use vmsish" to call
+it.
+
+EXAMPLE:
+ if ($quiet_exit) {
+ vmsish::hushed(1);
+ }
+ print "Sssshhhh...I'm hushed...\n" if vmsish::hushed();
+ exit 44;
+
+Note that an exit() or die() that is compiled 'hushed' because of "use
+vmsish" is not un-hushed by calling vmsish::hushed(0) at runtime.
+
+The messages from error exits from inside the Perl core are generally
+more serious, and are not supressed.
=back
my $bits = 0;
my $sememe;
foreach $sememe (@_) {
- $bits |= 0x20000000, next if $sememe eq 'hushed';
$bits |= 0x40000000, next if $sememe eq 'status' || $sememe eq '$?';
$bits |= 0x80000000, next if $sememe eq 'time';
}
sub import {
shift;
- $^H |= bits(@_ ? @_ : qw(status time hushed));
+ $^H |= bits(@_ ? @_ : qw(status time));
my $sememe;
- foreach $sememe (@_ ? @_ : qw(exit)) {
+ foreach $sememe (@_ ? @_ : qw(exit hushed)) {
$^H{'vmsish_exit'} = 1 if $sememe eq 'exit';
+ vmsish::hushed(1) if $sememe eq 'hushed';
}
}
sub unimport {
shift;
- $^H &= ~ bits(@_ ? @_ : qw(status time hushed));
+ $^H &= ~ bits(@_ ? @_ : qw(status time));
my $sememe;
- foreach $sememe (@_ ? @_ : qw(exit)) {
+ foreach $sememe (@_ ? @_ : qw(exit hushed)) {
$^H{'vmsish_exit'} = 0 if $sememe eq 'exit';
+ vmsish::hushed(0) if $sememe eq 'hushed';
}
}
my $Invoke_Perl = qq(MCR $^X "-I[-.lib]");
-print "1..17\n";
+require "test.pl";
+plan(tests => 24);
#========== vmsish status ==========
`$Invoke_Perl -e 1`; # Avoid system() from a pipe from harness. Mutter.
-if ($?) { print "not ok 1 # POSIX status is $?\n"; }
-else { print "ok 1\n"; }
+is($?,0,"simple Perl invokation: POSIX success status");
{
use vmsish qw(status);
- if (not ($? & 1)) { print "not ok 2 # vmsish status is $?\n"; }
- else { print "ok 2\n"; }
+ is(($? & 1),1, "importing vmsish [vmsish status]");
{
- no vmsish '$?'; # check unimport function
- if ($?) { print "not ok 3 # POSIX status is $?\n"; }
- else { print "ok 3\n"; }
+ no vmsish qw(status); # check unimport function
+ is($?,0, "unimport vmsish [POSIX STATUS]");
}
# and lexical scoping
- if (not ($? & 1)) { print "not ok 4 # vmsish status is $?\n"; }
- else { print "ok 4\n"; }
+ is(($? & 1),1,"lex scope of vmsish [vmsish status]");
}
-if ($?) { print "not ok 5 # POSIX status is $?\n"; }
-else { print "ok 5\n"; }
+is($?,0,"outer lex scope of vmsish [POSIX status]");
+
{
use vmsish qw(exit); # check import function
- if ($?) { print "not ok 6 # POSIX status is $?\n"; }
- else { print "ok 6\n"; }
+ is($?,0,"importing vmsish exit [POSIX status]");
}
#========== vmsish exit, messages ==========
use vmsish qw(status);
$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";
- }
- else { print "ok 7\n"; }
- if ($? & 1) { print "not ok 8 # subprocess VMS status: $?\n"; }
- else { print "ok 8\n"; }
+ like($msg,'ABORT', "POSIX ERR exit, DCL error message check");
+ is($?&1,0,"vmsish status check, POSIX ERR exit");
$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";
- }
- else { print "ok 9\n"; }
- if (not ($? & 1)) { print "not ok 10 # subprocess VMS status: $?\n"; }
- else { print "ok 10\n"; }
+ ok(length($msg)==0,"vmsish OK exit, DCL error message check");
+ is($?&1,1, "vmsish status check, vmsish OK exit");
$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"; }
+ like($msg, 'ABORT', "vmsish ERR exit, DCL error message check");
+ is($?&1,0,"vmsish ERR exit, vmsish status check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); exit 1"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"POSIX ERR exit, vmsish hushed, DCL error message check");
$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"; }
-
+ ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit hushed); no vmsish qw(hushed); exit 44"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ like($msg,'ABORT',"vmsish ERR exit, no vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); die(qw(blah));"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"die, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(hushed); use Carp; croak(qw(blah));"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"croak, vmsish hushed, DCL error message check");
+
+ $msg = do_a_perl('-e "use vmsish qw(exit); vmsish::hushed(1); exit 44;"');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"vmsish ERR exit, vmsish hushed at runtime, DCL error message check");
+
+ local *TEST;
+ open(TEST,'>vmsish_test.pl') || die('not ok ?? : unable to open "vmsish_test.pl" for writing');
+ print TEST "#! perl\n";
+ print TEST "use vmsish qw(hushed);\n";
+ print TEST "\$obvious = (\$compile(\$error;\n";
+ close TEST;
+ $msg = do_a_perl('vmsish_test.pl');
+ $msg =~ s/\n/\\n/g; # keep output on one line
+ ok(($msg !~ /ABORT/),"compile ERR exit, vmsish hushed, DCL error message check");
+ unlink 'vmsish_test.pl';
}
gmtime(0); # Force reset of tz offset
}
{
- use vmsish qw(time);
+ use_ok('vmsish qw(time)');
$vmstime = time;
@vmslocal = localtime($vmstime);
@vmsgmtime = gmtime($vmstime);
# since it's unlikely local time will differ from UTC by so small
# 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 14 # (time) UTC: $utctime VMS: $vmstime\n";
- }
- else { print "ok 14\n"; }
+ ok($utctime - $vmstime +$offset <= 10,"(time) UTC:$utctime VMS:$vmstime");
$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 15 # (localtime)\n# UTC: @utclocal\n# VMS: @vmslocal\n";
- }
- else { print "ok 15\n"; }
+ ok($vmsval - $utcval + $offset <= 10, "(localtime)\n# UTC: @utclocal\n# VMS: @vmslocal");
$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 16 # (gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime\n";
- }
- else { print "ok 16\n"; }
+ ok($vmsval - $utcval + $offset <= 10, "(gmtime)\n# UTC: @utcgmtime\n# VMS: @vmsgmtime");
- if ($vmsmtime - $utcmtime + $offset > 10) {
- print "not ok 17 # (stat) UTC: $utcmtime VMS: $vmsmtime\n";
- }
- else { print "ok 17\n"; }
+ ok($vmsmtime - $utcmtime + $offset <= 10,"(stat) UTC: $utcmtime VMS: $vmsmtime");
}
#====== need this to make sure error messages come out, even if
}
void
+hushexit_fromperl(pTHX_ CV *cv)
+{
+ dXSARGS;
+
+ if (items > 0) {
+ VMSISH_HUSHED = SvTRUE(ST(0));
+ }
+ ST(0) = boolSV(VMSISH_HUSHED);
+ XSRETURN(1);
+}
+
+void
+Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
+ struct interp_intern *dst)
+{
+ memcpy(dst,src,sizeof(struct interp_intern));
+}
+
+void
+Perl_sys_intern_clear(pTHX)
+{
+}
+
+void
+Perl_sys_intern_init(pTHX)
+{
+ int ix = RAND_MAX;
+ float x;
+
+ VMSISH_HUSHED = 0;
+
+ x = (float)ix;
+ MY_INV_RAND_MAX = 1./x;
+}
+
+
+
+void
init_os_extras()
{
dTHX;
newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
+ newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
store_pipelocs(aTHX);
-#ifdef Drand01_is_rand
-/* this hackery brought to you by a bug in DECC for /ieee=denorm */
- {
- int ix = RAND_MAX;
- float x = (float)ix;
- PL_my_inv_rand_max = 1./x;
- }
-#endif
-
return;
}
#define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */
#define HINT_V_VMSISH 24
-#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_TIME TEST_VMSISH(HINT_M_VMSISH_TIME)
+/* VMS-specific data storage */
+
+#define HAVE_INTERP_INTERN
+struct interp_intern {
+ int hushed;
+ float inv_rand_max;
+};
+#define VMSISH_HUSHED (PL_sys_intern.hushed)
+#define MY_INV_RAND_MAX (PL_sys_intern.inv_rand_max)
+
/* Flags for vmstrnenv() */
#define PERL__TRNENV_SECURE 0x01
projects / platform / upstream / perl.git / commitdiff