X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=a77c8865e513b9666864993d17e97ea3d7fab537;hb=4a8ebb7f2bc69c2b7689190ca0f678605f6299e9;hp=cab20e322958c1bdd97749e1649b08d22d98eb18;hpb=417cd4a80014be11be785b60728258129d31e986;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index cab20e3..a77c886 100644 --- a/perl.c +++ b/perl.c @@ -137,6 +137,14 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif +#ifndef NO_MATHOMS +/* This reference ensure that the mathoms are linked with perl */ +void Perl_mathoms_ref() { + extern void Perl_mathoms(); + Perl_mathoms(); +} +#endif + static void S_init_tls_and_interp(PerlInterpreter *my_perl) { @@ -259,7 +267,9 @@ perl_construct(pTHXx) } PL_sighandlerp = (Sighandler_t) Perl_sighandler; +#ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); +#endif } PL_rs = newSVpvn("\n", 1); @@ -808,10 +818,10 @@ perl_destruct(pTHXx) */ { I32 i = AvFILLp(PL_regex_padav) + 1; - SV **ary = AvARRAY(PL_regex_padav); + SV * const * const ary = AvARRAY(PL_regex_padav); while (i) { - SV *resv = ary[--i]; + SV * const resv = ary[--i]; if (SvFLAGS(resv) & SVf_BREAK) { /* this is PL_reg_curpm, already freed @@ -952,8 +962,10 @@ perl_destruct(pTHXx) PL_subname = Nullsv; SvREFCNT_dec(PL_linestr); PL_linestr = Nullsv; +#ifdef PERL_USES_PL_PIDSTATUS SvREFCNT_dec(PL_pidstatus); PL_pidstatus = Nullhv; +#endif SvREFCNT_dec(PL_toptarget); PL_toptarget = Nullsv; SvREFCNT_dec(PL_bodytarget); @@ -1085,7 +1097,7 @@ perl_destruct(pTHXx) */ I32 riter = 0; const I32 max = HvMAX(PL_strtab); - HE ** const array = HvARRAY(PL_strtab); + HE * const * const array = HvARRAY(PL_strtab); HE *hent = array[0]; for (;;) { @@ -1770,9 +1782,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_USE_SAFE_PUTENV " PERL_USE_SAFE_PUTENV" # endif +#ifdef PERL_USES_PL_PIDSTATUS + " PERL_USES_PL_PIDSTATUS" +#endif # ifdef PL_OP_SLAB_ALLOC " PL_OP_SLAB_ALLOC" # endif +# ifdef SPRINTF_RETURNS_STRLEN + " SPRINTF_RETURNS_STRLEN" +# endif # ifdef THREADS_HAVE_PIDS " THREADS_HAVE_PIDS" # endif @@ -1816,7 +1834,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) */ const char *space; - char *pv = SvPV_nolen(opts_prog); + char * const pv = SvPV_nolen(opts_prog); const char c = pv[opts+76]; pv[opts+76] = '\0'; space = strrchr(pv+opts+26, ' '); @@ -2070,7 +2088,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) * or explicitly in some platforms. * locale.c:Perl_init_i18nl10n() if the environment * look like the user wants to use UTF-8. */ -#if defined(SYMBIAN) +#if defined(__SYMBIAN32__) PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ #endif if (PL_unicode) { @@ -2327,7 +2345,7 @@ set and the variable does not exist then NULL is returned. AV* Perl_get_av(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVAV); + GV* const gv = gv_fetchpv(name, create, SVt_PVAV); if (create) return GvAVn(gv); if (gv) @@ -2374,7 +2392,7 @@ subroutine does not exist then NULL is returned. CV* Perl_get_cv(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVCV); + GV* const gv = gv_fetchpv(name, create, SVt_PVCV); /* XXX unsafe for threads if eval_owner isn't held */ /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward @@ -2476,7 +2494,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) I32 oldscope; bool oldcatch = CATCH_GET; int ret; - OP* oldop = PL_op; + OP* const oldop = PL_op; dJMPENV; if (flags & G_DISCARD) { @@ -2643,7 +2661,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) volatile I32 oldmark = SP - PL_stack_base; volatile I32 retval = 0; int ret; - OP* oldop = PL_op; + OP* const oldop = PL_op; dJMPENV; if (flags & G_DISCARD) { @@ -2776,9 +2794,9 @@ Perl_require_pv(pTHX_ const char *pv) void Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen) { - register GV *gv; + register GV * const gv = gv_fetchpv(sym,TRUE, SVt_PV); - if ((gv = gv_fetchpv(sym,TRUE, SVt_PV))) + if (gv) sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen); } @@ -2870,7 +2888,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq"; for (; isALNUM(**s); (*s)++) { - const char *d = strchr(debopts,**s); + const char * const d = strchr(debopts,**s); if (d) i |= 1 << (d - debopts); else if (ckWARN_d(WARN_DEBUGGING)) @@ -2979,8 +2997,7 @@ Perl_moreswitches(pTHX_ char *s) in the fashion that -MSome::Mod does. */ if (*s == ':' || *s == '=') { const char *start; - SV *sv; - sv = newSVpv("use Devel::", 0); + SV * const sv = newSVpv("use Devel::", 0); start = ++s; /* We now allow -d:Module=Foo,Bar */ while(isALNUM(*s) || *s==':') ++s; @@ -3272,7 +3289,7 @@ Perl_moreswitches(pTHX_ char *s) PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n"); wce_hitreturn(); #endif -#ifdef SYMBIAN +#ifdef __SYMBIAN32__ PerlIO_printf(PerlIO_stdout(), "Symbian port by Nokia, 2004-2005\n"); #endif @@ -3530,9 +3547,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) } #else /* IAMSUID */ else if (PL_preprocess) { - const char *cpp_cfg = CPPSTDIN; - SV *cpp = newSVpvn("",0); - SV *cmd = NEWSV(0,0); + const char * const cpp_cfg = CPPSTDIN; + SV * const cpp = newSVpvn("",0); + SV * const cmd = NEWSV(0,0); if (cpp_cfg[0] == 0) /* PERL_MICRO? */ Perl_croak(aTHX_ "Can't run with cpp -P with CPPSTDIN undefined"); @@ -3704,10 +3721,9 @@ S_fd_on_nosuid_fs(pTHX_ int fd) cmplen = sizeof(fsd.fd_req.path); if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) && fdst.st_dev == fsd.fd_req.dev) { - check_okay = 1; - on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; - on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC; - } + check_okay = 1; + on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID; + on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC; } } } @@ -4328,7 +4344,7 @@ S_forbid_setid(pTHX_ const char *s) void Perl_init_debugger(pTHX) { - HV *ostash = PL_curstash; + HV * const ostash = PL_curstash; PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("DB::args", GV_ADDMULTI, SVt_PVAV)))); @@ -4715,7 +4731,7 @@ S_init_perllib(pTHX) #endif /* MACOS_TRADITIONAL */ } -#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN) +#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__) # define PERLLIB_SEP ';' #else # if defined(VMS) @@ -4899,8 +4915,8 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, if (addsubdirs || addoldvers) { #ifdef PERL_INC_VERSION_LIST /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ - const char *incverlist[] = { PERL_INC_VERSION_LIST }; - const char **incver; + const char * const incverlist[] = { PERL_INC_VERSION_LIST }; + const char * const *incver; #endif #ifdef VMS char *unix; @@ -5155,7 +5171,7 @@ Perl_my_exit(pTHX_ U32 status) STATUS_ALL_FAILURE; break; default: - STATUS_UNIX_SET(status); + STATUS_EXIT_SET(status); break; } my_exit_jump(); @@ -5165,16 +5181,60 @@ void Perl_my_failure_exit(pTHX) { #ifdef VMS - if (vaxc$errno & 1) { - if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */ - STATUS_NATIVE_SET(44); + /* We have been called to fall on our sword. The desired exit code + * should be already set in STATUS_UNIX, but could be shifted over + * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a + * that code is set. + * + * If an error code has not been set, then force the issue. + */ + if (MY_POSIX_EXIT) { + + /* In POSIX_EXIT mode follow Perl documentations and use 255 for + * the exit code when there isn't an error. + */ + + if (STATUS_UNIX == 0) + STATUS_UNIX_EXIT_SET(255); + else { + STATUS_UNIX_EXIT_SET(STATUS_UNIX); + + /* The exit code could have been set by $? or vmsish which + * means that it may not be fatal. So convert + * success/warning codes to fatal. + */ + if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) + STATUS_UNIX_EXIT_SET(255); + } } else { - if (!vaxc$errno) /* unlikely */ - STATUS_NATIVE_SET(44); - else - STATUS_NATIVE_SET(vaxc$errno); + /* Traditionally Perl on VMS always expects a Fatal Error. */ + if (vaxc$errno & 1) { + + /* So force success status to failure */ + if (STATUS_NATIVE & 1) + STATUS_ALL_FAILURE; + } + else { + if (!vaxc$errno) { + STATUS_UNIX = EINTR; /* In case something cares */ + STATUS_ALL_FAILURE; + } + else { + int severity; + STATUS_NATIVE = vaxc$errno; /* Should already be this */ + + /* Encode the severity code */ + severity = STATUS_NATIVE & STS$M_SEVERITY; + STATUS_UNIX = (severity ? severity : 1) << 8; + + /* Perl expects this to be a fatal error */ + if (severity != STS$K_SEVERE) + STATUS_ALL_FAILURE; + } + } } + #else int exitstatus; if (errno & 255)