X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=a77c8865e513b9666864993d17e97ea3d7fab537;hb=4a8ebb7f2bc69c2b7689190ca0f678605f6299e9;hp=3cb25ea51eae6d5939789845188884c76a4d18fe;hpb=37038d913ecbccf83ca988aedaa1e6067b127dbc;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 3cb25ea..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); @@ -347,7 +357,7 @@ perl_construct(pTHXx) # endif if ((long) PL_mmap_page_size < 0) { if (errno) { - SV *error = ERRSV; + SV * const error = ERRSV; (void) SvUPGRADE(error, SVt_PV); Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); } @@ -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,15 +1097,15 @@ perl_destruct(pTHXx) */ I32 riter = 0; const I32 max = HvMAX(PL_strtab); - HE **array = HvARRAY(PL_strtab); + HE * const * const array = HvARRAY(PL_strtab); HE *hent = array[0]; for (;;) { if (hent && ckWARN_d(WARN_INTERNAL)) { - HE *next = HeNEXT(hent); + HE * const next = HeNEXT(hent); Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced string table refcount: (%d) for \"%s\"", - HeVAL(hent) - Nullsv, HeKEY(hent)); + "Unbalanced string table refcount: (%ld) for \"%s\"", + (long)(HeVAL(hent) - Nullsv), HeKEY(hent)); Safefree(hent); hent = next; } @@ -1767,9 +1779,18 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_OLD_COPY_ON_WRITE " PERL_OLD_COPY_ON_WRITE" # endif +# 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 @@ -1813,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, ' '); @@ -1934,7 +1955,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) d = s; if (!*s) break; - if (!strchr("DIMUdmtwA", *s)) + if (!strchr("CDIMUdmtwA", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); while (++s && *s) { if (isSPACE(*s)) { @@ -2067,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) { @@ -2324,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) @@ -2371,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 @@ -2473,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) { @@ -2640,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) { @@ -2773,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); } @@ -2867,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)) @@ -2880,7 +2901,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) for (; isALNUM(**s); (*s)++) ; } else if (givehelp) { - char **p = (char **)usage_msgd; + const char *const *p = usage_msgd; while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++); } # ifdef EBCDIC @@ -2976,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; @@ -3084,8 +3104,8 @@ Perl_moreswitches(pTHX_ char *s) PL_preambleav = newAV(); s++; { - char *start = s; - SV *sv = newSVpv("use assertions::activate", 24); + char * const start = s; + SV * const sv = newSVpv("use assertions::activate", 24); while(isALNUM(*s) || *s == ':') ++s; if (s != start) { sv_catpvn(sv, "::", 2); @@ -3096,7 +3116,7 @@ Perl_moreswitches(pTHX_ char *s) s+=strlen(s); } else if (*s != '\0') { - Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start); + Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start); } av_push(PL_preambleav, sv); return s; @@ -3269,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 @@ -3527,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"); @@ -3607,8 +3627,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) #endif /* IAMSUID */ if (!PL_rsfp) { /* PSz 16 Sep 03 Keep neat error message */ - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); + if (PL_e_script) + Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno)); + else + Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", + CopFILE(PL_curcop), Strerror(errno)); } } @@ -3698,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; } } } @@ -4322,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)))); @@ -4592,7 +4614,16 @@ S_init_perllib(pTHX) if (!PL_tainting) { #ifndef VMS s = PerlEnv_getenv("PERL5LIB"); +/* + * It isn't possible to delete an environment variable with + * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that + * case we treat PERL5LIB as undefined if it has a zero-length value. + */ +#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) + if (s && *s != '\0') +#else if (s) +#endif incpush(s, TRUE, TRUE, TRUE, FALSE); else incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE); @@ -4700,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) @@ -4884,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; @@ -5140,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(); @@ -5150,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)