X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=a77c8865e513b9666864993d17e97ea3d7fab537;hb=4a8ebb7f2bc69c2b7689190ca0f678605f6299e9;hp=3ff4a80eec762031d99fe1f0cc4d47547696c9f9;hpb=8aad04aa6a2ab20a526b53089f8919d46434ca7e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 3ff4a80..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)); } @@ -546,7 +556,7 @@ perl_destruct(pTHXx) if (CALL_FPTR(PL_threadhook)(aTHX)) { /* Threads hook has vetoed further cleanup */ - return STATUS_NATIVE_EXPORT; + return STATUS_EXIT; } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP @@ -739,6 +749,8 @@ perl_destruct(pTHXx) */ sv_clean_objs(); PL_sv_objcount = 0; + if (PL_defoutgv && !SvREFCNT(PL_defoutgv)) + PL_defoutgv = Nullgv; /* may have been freed */ } /* unhook hooks which will soon be, or use, destroyed data */ @@ -766,7 +778,7 @@ perl_destruct(pTHXx) #endif /* The exit() function will do everything that needs doing. */ - return STATUS_NATIVE_EXPORT; + return STATUS_EXIT; } /* jettison our possibly duplicated environment */ @@ -806,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 @@ -950,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); @@ -1083,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; } @@ -1257,7 +1271,7 @@ perl_destruct(pTHXx) Safefree(PL_mess_sv); PL_mess_sv = Nullsv; } - return STATUS_NATIVE_EXPORT; + return STATUS_EXIT; } /* @@ -1553,7 +1567,7 @@ setuid perl scripts securely.\n"); PL_curstash = PL_defstash; if (PL_checkav) call_list(oldscope, PL_checkav); - ret = STATUS_NATIVE_EXPORT; + ret = STATUS_EXIT; break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); @@ -1725,92 +1739,102 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif opts = SvCUR(opts_prog); - sv_catpv(opts_prog,"\" Compile-time options:"); + Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:" # ifdef DEBUGGING - sv_catpv(opts_prog," DEBUGGING"); + " DEBUGGING" # endif # ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - sv_catpv(opts_prog," DEBUG_LEAKING_SCALARS_FORK_DUMP"); + " DEBUG_LEAKING_SCALARS_FORK_DUMP" # endif # ifdef FAKE_THREADS - sv_catpv(opts_prog," FAKE_THREADS"); + " FAKE_THREADS" # endif # ifdef MULTIPLICITY - sv_catpv(opts_prog," MULTIPLICITY"); + " MULTIPLICITY" # endif # ifdef MYMALLOC - sv_catpv(opts_prog," MYMALLOC"); + " MYMALLOC" # endif # ifdef PERL_DONT_CREATE_GVSV - sv_catpv(opts_prog," PERL_DONT_CREATE_GVSV"); + " PERL_DONT_CREATE_GVSV" # endif # ifdef PERL_GLOBAL_STRUCT - sv_catpv(opts_prog," PERL_GLOBAL_STRUCT"); + " PERL_GLOBAL_STRUCT" # endif # ifdef PERL_IMPLICIT_CONTEXT - sv_catpv(opts_prog," PERL_IMPLICIT_CONTEXT"); + " PERL_IMPLICIT_CONTEXT" # endif # ifdef PERL_IMPLICIT_SYS - sv_catpv(opts_prog," PERL_IMPLICIT_SYS"); + " PERL_IMPLICIT_SYS" # endif # ifdef PERL_MALLOC_WRAP - sv_catpv(opts_prog," PERL_MALLOC_WRAP"); + " PERL_MALLOC_WRAP" # endif # ifdef PERL_NEED_APPCTX - sv_catpv(opts_prog," PERL_NEED_APPCTX"); + " PERL_NEED_APPCTX" # endif # ifdef PERL_NEED_TIMESBASE - sv_catpv(opts_prog," PERL_NEED_TIMESBASE"); + " PERL_NEED_TIMESBASE" # endif # ifdef PERL_OLD_COPY_ON_WRITE - sv_catpv(opts_prog," 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 - sv_catpv(opts_prog," PL_OP_SLAB_ALLOC"); + " PL_OP_SLAB_ALLOC" +# endif +# ifdef SPRINTF_RETURNS_STRLEN + " SPRINTF_RETURNS_STRLEN" # endif # ifdef THREADS_HAVE_PIDS - sv_catpv(opts_prog," THREADS_HAVE_PIDS"); + " THREADS_HAVE_PIDS" # endif # ifdef USE_5005THREADS - sv_catpv(opts_prog," USE_5005THREADS"); + " USE_5005THREADS" # endif # ifdef USE_64_BIT_ALL - sv_catpv(opts_prog," USE_64_BIT_ALL"); + " USE_64_BIT_ALL" # endif # ifdef USE_64_BIT_INT - sv_catpv(opts_prog," USE_64_BIT_INT"); + " USE_64_BIT_INT" # endif # ifdef USE_ITHREADS - sv_catpv(opts_prog," USE_ITHREADS"); + " USE_ITHREADS" # endif # ifdef USE_LARGE_FILES - sv_catpv(opts_prog," USE_LARGE_FILES"); + " USE_LARGE_FILES" # endif # ifdef USE_LONG_DOUBLE - sv_catpv(opts_prog," USE_LONG_DOUBLE"); + " USE_LONG_DOUBLE" # endif # ifdef USE_PERLIO - sv_catpv(opts_prog," USE_PERLIO"); + " USE_PERLIO" # endif # ifdef USE_REENTRANT_API - sv_catpv(opts_prog," USE_REENTRANT_API"); + " USE_REENTRANT_API" # endif # ifdef USE_SFIO - sv_catpv(opts_prog," USE_SFIO"); + " USE_SFIO" # endif # ifdef USE_SITECUSTOMIZE - sv_catpv(opts_prog," USE_SITECUSTOMIZE"); + " USE_SITECUSTOMIZE" # endif # ifdef USE_SOCKS - sv_catpv(opts_prog," USE_SOCKS"); + " USE_SOCKS" # endif + ); while (SvCUR(opts_prog) > opts+76) { /* find last space after "options: " and before col 76 */ 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, ' '); @@ -1931,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)) { @@ -2064,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) { @@ -2212,7 +2236,7 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - ret = STATUS_NATIVE_EXPORT; + ret = STATUS_EXIT; break; case 3: if (PL_restartop) { @@ -2238,8 +2262,10 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { DEBUG_x(dump_all()); +#ifdef DEBUGGING if (!DEBUG_q_TEST) PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); +#endif DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", PTR2UV(thr))); @@ -2319,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) @@ -2366,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 @@ -2468,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) { @@ -2635,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) { @@ -2768,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); } @@ -2862,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)) @@ -2875,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 @@ -2971,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; @@ -3079,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); @@ -3091,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; @@ -3264,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 @@ -3413,7 +3438,7 @@ S_init_main_stash(pTHX) SvREFCNT_dec(GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); SvREADONLY_on(gv); - Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0); + hv_name_set(PL_defstash, "main", 4, 0); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ @@ -3522,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"); @@ -3602,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)); } } @@ -3693,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; } } } @@ -4317,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)))); @@ -4587,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); @@ -4695,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) @@ -4879,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; @@ -5135,7 +5171,7 @@ Perl_my_exit(pTHX_ U32 status) STATUS_ALL_FAILURE; break; default: - STATUS_NATIVE_SET(status); + STATUS_EXIT_SET(status); break; } my_exit_jump(); @@ -5145,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)