diff options
| -rw-r--r-- | configure.com | 5 | ||||
| -rw-r--r-- | dump.c | 8 | ||||
| -rwxr-xr-x | ext/B/t/stash.t | 1 | ||||
| -rw-r--r-- | op.c | 10 | ||||
| -rw-r--r-- | op.h | 3 | ||||
| -rw-r--r-- | opcode.h | 2 | ||||
| -rwxr-xr-x | opcode.pl | 2 | ||||
| -rw-r--r-- | perl.c | 3 | ||||
| -rw-r--r-- | perl.h | 3 | ||||
| -rw-r--r-- | perlvars.h | 4 | ||||
| -rw-r--r-- | pp.sym | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 1 | ||||
| -rw-r--r-- | pp_proto.h | 1 | ||||
| -rw-r--r-- | pp_sys.c | 3 | ||||
| -rw-r--r-- | vms/ext/vmsish.pm | 74 | ||||
| -rw-r--r-- | vms/ext/vmsish.t | 107 | ||||
| -rw-r--r-- | vms/vms.c | 48 | ||||
| -rw-r--r-- | vms/vmsish.h | 12 |
18 files changed, 198 insertions, 90 deletions
diff --git a/configure.com b/configure.com index 82fa3ed4a0..2c4f1be9d2 100644 --- a/configure.com +++ b/configure.com @@ -4514,7 +4514,6 @@ $! $! 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>" @@ -4555,10 +4554,9 @@ $ IF compile_status .EQ. good_compile .AND. link_status .EQ. good_link $ 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 @@ -5732,7 +5730,6 @@ $ THEN $! 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..." @@ -616,7 +616,13 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) } 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"); diff --git a/ext/B/t/stash.t b/ext/B/t/stash.t index b83493fe34..88e4ca2492 100755 --- a/ext/B/t/stash.t +++ b/ext/B/t/stash.t @@ -42,6 +42,7 @@ $a =~ s/-uCwd,// if $^O eq 'cygwin'; 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 } @@ -5432,6 +5432,15 @@ Perl_ck_delete(pTHX_ OP *o) } 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; @@ -5500,6 +5509,7 @@ Perl_ck_exit(pTHX_ OP *o) if (svp && *svp && SvTRUE(*svp)) o->op_private |= OPpEXIT_VMSISH; } + if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH; #endif return ck_fun(o); } @@ -197,7 +197,8 @@ 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 */ +/* 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 { @@ -1273,7 +1273,7 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *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 */ @@ -652,7 +652,7 @@ leavesub subroutine exit ck_null 1 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 @ @@ -1492,6 +1492,9 @@ perl_run(pTHXx) #endif oldscope = PL_scopestack_ix; +#ifdef VMS + VMSISH_HUSHED = 0; +#endif #ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: @@ -425,7 +425,7 @@ int usleep(unsigned int); # define MYSWAP #endif -#if !defined(PERL_FOR_X2P) && !defined(WIN32) +#if !defined(PERL_FOR_X2P) && !(defined(WIN32)||defined(VMS)) # include "embed.h" #endif @@ -1754,6 +1754,7 @@ typedef struct clone_params CLONE_PARAMS; #else # if defined(VMS) # include "vmsish.h" +# include "embed.h" # else # if defined(PLAN9) # include "./plan9/plan9ish.h" diff --git a/perlvars.h b/perlvars.h index e70dd7f772..704192422a 100644 --- a/perlvars.h +++ b/perlvars.h @@ -40,7 +40,3 @@ PERLVAR(Gop_mutex, perl_mutex) /* Mutex for op refcounting */ 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 @@ -9,6 +9,7 @@ Perl_ck_bitop Perl_ck_concat Perl_ck_defined Perl_ck_delete +Perl_ck_die Perl_ck_eof Perl_ck_eval Perl_ck_exec @@ -2593,6 +2593,7 @@ PP(pp_exit) #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; diff --git a/pp_proto.h b/pp_proto.h index 86ab4c2550..566074e0f2 100644 --- a/pp_proto.h +++ b/pp_proto.h @@ -8,6 +8,7 @@ PERL_CKDEF(Perl_ck_bitop) 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) @@ -433,6 +433,9 @@ PP(pp_die) 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); diff --git a/vms/ext/vmsish.pm b/vms/ext/vmsish.pm index c51863a4f3..89ec72c28c 100644 --- a/vms/ext/vmsish.pm +++ b/vms/ext/vmsish.pm @@ -11,7 +11,10 @@ vmsish - Perl pragma to control VMS-specific language features use vmsish 'status'; # or '$?' use vmsish 'exit'; use vmsish 'time'; + use vmsish 'hushed'; + no vmsish 'hushed'; + vmsish::hushed($hush); use vmsish; no vmsish 'time'; @@ -44,13 +47,59 @@ default of Universal Time (a.k.a Greenwich Mean Time, or GMT). =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 @@ -67,7 +116,6 @@ sub bits { 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'; } @@ -76,21 +124,23 @@ sub bits { 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'; } } diff --git a/vms/ext/vmsish.t b/vms/ext/vmsish.t index d63da57235..0f3c0ec1eb 100644 --- a/vms/ext/vmsish.t +++ b/vms/ext/vmsish.t @@ -3,31 +3,27 @@ BEGIN { unshift @INC, '[-.lib]'; } 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 ========== @@ -35,39 +31,54 @@ else { print "ok 5\n"; } 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'; } @@ -84,7 +95,7 @@ else { print "ok 5\n"; } gmtime(0); # Force reset of tz offset } { - use vmsish qw(time); + use_ok('vmsish qw(time)'); $vmstime = time; @vmslocal = localtime($vmstime); @vmsgmtime = gmtime($vmstime); @@ -101,33 +112,21 @@ else { print "ok 5\n"; } # 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 @@ -6911,6 +6911,44 @@ mod2fname(pTHX_ CV *cv) } 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; @@ -6932,18 +6970,10 @@ init_os_extras() 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; } diff --git a/vms/vmsish.h b/vms/vmsish.h index 93af772415..34062b7a07 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -285,16 +285,24 @@ #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 |