X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b1681ed3d2d7fce28f676043b07816f4fad94f55..23c2666825f6d4396328e332025722d15959b207:/perl.c diff --git a/perl.c b/perl.c index 42f32fe..4b005b6 100644 --- a/perl.c +++ b/perl.c @@ -137,6 +137,15 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); #endif #endif +#ifndef NO_MATHOMS +/* This reference ensures that the mathoms are linked with perl */ +extern void Perl_mathoms(void); +void Perl_mathoms_ref(void); +void Perl_mathoms_ref(void) { + Perl_mathoms(); +} +#endif + static void S_init_tls_and_interp(PerlInterpreter *my_perl) { @@ -259,7 +268,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 +819,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 +963,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 +1098,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 (;;) { @@ -1731,6 +1744,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef DEBUGGING " DEBUGGING" # endif +# ifdef DEBUG_LEAKING_SCALARS + " DEBUG_LEAKING_SCALARS" +# endif # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP " DEBUG_LEAKING_SCALARS_FORK_DUMP" # endif @@ -1743,6 +1759,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef MYMALLOC " MYMALLOC" # endif +# ifdef NO_MATHOMS + " NO_MATHOMS" +# endif # ifdef PERL_DONT_CREATE_GVSV " PERL_DONT_CREATE_GVSV" # endif @@ -1767,9 +1786,21 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_OLD_COPY_ON_WRITE " PERL_OLD_COPY_ON_WRITE" # endif +# ifdef PERL_TRACK_MEMPOOL + " PERL_TRACK_MEMPOOL" +# 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 +1844,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, ' '); @@ -2043,7 +2074,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (xsinit) (*xsinit)(aTHX); /* in case linked C routines want magical variables */ #ifndef PERL_MICRO -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) || defined(SYMBIAN) init_os_extras(); #endif #endif @@ -2067,7 +2098,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 +2355,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 +2402,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 +2504,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 +2671,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 +2804,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 +2898,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)) @@ -2976,8 +3007,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; @@ -3096,7 +3126,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 +3299,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 @@ -3420,11 +3450,14 @@ S_init_main_stash(pTHX) SvREADONLY_on(gv); hv_name_set(PL_defstash, "main", 4, 0); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); + SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ GvMULTI_on(PL_hintgv); PL_defgv = gv_fetchpv("_",TRUE, SVt_PVAV); + SvREFCNT_inc(PL_defgv); PL_errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); + SvREFCNT_inc(PL_errgv); GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); @@ -3527,9 +3560,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"); @@ -3701,10 +3734,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; } } } @@ -3793,6 +3825,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) { I32 len; const char *linestr; + const char *s_end; #ifdef IAMSUID if (PL_fdscript < 0 || PL_suidscript != 1) @@ -3898,7 +3931,8 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) s = linestr; /* PSz 27 Feb 04 */ /* Sanity check on line length */ - if (strlen(s) < 1 || strlen(s) > 4000) + s_end = s + strlen(s); + if (s_end == s || (s_end - s) > 4000) Perl_croak(aTHX_ "Very long #! line"); /* Allow more than a single space after #! */ while (isSPACE(*s)) s++; @@ -3937,7 +3971,8 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) len = strlen(validarg); if (strEQ(validarg," PHOOEY ") || strnNE(s,validarg,len) || !isSPACE(s[len]) || - !(strlen(s) == len+1 || (strlen(s) == len+2 && isSPACE(s[len+1])))) + !((s_end - s) == len+1 + || ((s_end - s) == len+2 && isSPACE(s[len+1])))) Perl_croak(aTHX_ "Args must match #! line"); #ifndef IAMSUID @@ -4325,7 +4360,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)))); @@ -4712,7 +4747,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) @@ -4896,8 +4931,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; @@ -5152,7 +5187,7 @@ Perl_my_exit(pTHX_ U32 status) STATUS_ALL_FAILURE; break; default: - STATUS_UNIX_SET(status); + STATUS_EXIT_SET(status); break; } my_exit_jump(); @@ -5162,16 +5197,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)