X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=7a53b72e74efb7424c91425de304acd412094198;hb=61626fd500e6d4ce66fd252d4006308416a874bb;hp=fdcbcbdaaf6a01c38ba302216ecb2c12c9879926;hpb=c301d6064f299b8a77670348b81d25d2d94d6a2f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index fdcbcbd..7a53b72 100644 --- a/perl.c +++ b/perl.c @@ -171,7 +171,12 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) MUTEX_INIT(&PL_my_ctx_mutex); # endif } - else { +#if defined(USE_ITHREADS) + else +#else + /* This always happens for non-ithreads */ +#endif + { PERL_SET_THX(my_perl); } } @@ -321,8 +326,8 @@ perl_construct(pTHXx) sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ #ifdef USE_ITHREADS - PL_regex_padav = newAV(); - av_push(PL_regex_padav,(SV*)newAV()); /* First entry is an array of empty elements */ + /* First entry is an array of empty elements */ + Perl_av_create_and_push(aTHX_ &PL_regex_padav,(SV*)newAV()); PL_regex_pad = AvARRAY(PL_regex_padav); #endif #ifdef USE_REENTRANT_API @@ -1326,6 +1331,8 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { + dVAR; + if (PL_veto_cleanup) return; @@ -1549,8 +1556,10 @@ setuid perl scripts securely.\n"); break; } } + +#ifndef PERL_USE_SAFE_PUTENV /* Can we grab env area too to be used as the area for $0? */ - if (s && PL_origenviron) { + if (s && PL_origenviron && !PL_use_safe_putenv) { if ((PL_origenviron[0] == s + 1) || (aligned && @@ -1582,6 +1591,8 @@ setuid perl scripts securely.\n"); } } } +#endif /* !defined(PERL_USE_SAFE_PUTENV) */ + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } @@ -1794,10 +1805,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { SV *opts_prog; - if (!PL_preambleav) - PL_preambleav = newAV(); - av_push(PL_preambleav, - newSVpvs("use Config;")); + Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;")); if (*++s != ':') { STRLEN opts; @@ -2058,10 +2066,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef USE_SITECUSTOMIZE if (!minus_f) { - if (!PL_preambleav) - PL_preambleav = newAV(); - av_unshift(PL_preambleav, 1); - (void)av_store(PL_preambleav, 0, Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP)); + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP)); } #endif @@ -2476,33 +2482,46 @@ Perl_get_hv(pTHX_ const char *name, I32 create) /* =head1 CV Manipulation Functions +=for apidoc p||get_cvn_flags + +Returns the CV of the specified Perl subroutine. C are passed to +C. If C is set and the Perl subroutine does not +exist then it will be declared (which has the same effect as saying +C). If C is not set and the subroutine does not exist +then NULL is returned. + =for apidoc p||get_cv -Returns the CV of the specified Perl subroutine. If C is set and -the Perl subroutine does not exist then it will be declared (which has the -same effect as saying C). If C is not set and the -subroutine does not exist then NULL is returned. +Uses C to get the length of C, then calls C. =cut */ CV* -Perl_get_cv(pTHX_ const char *name, I32 create) +Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) { - GV* const gv = gv_fetchpv(name, create, SVt_PVCV); - /* XXX unsafe for threads if eval_owner isn't held */ + GV* const gv = gv_fetchpvn_flags(name, len, flags, SVt_PVCV); /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ - if (create && !GvCVu(gv)) + if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { + SV *const sv = newSVpvn(name,len); + SvFLAGS(sv) |= flags & SVf_UTF8; return newSUB(start_subparse(FALSE, 0), - newSVOP(OP_CONST, 0, newSVpv(name,0)), + newSVOP(OP_CONST, 0, sv), NULL, NULL); + } if (gv) return GvCVu(gv); return NULL; } +CV* +Perl_get_cv(pTHX_ const char *name, I32 flags) +{ + return get_cvn_flags(name, strlen(name), flags); +} + /* Be sure to refetch the stack pointer after calling these routines. */ /* @@ -3166,8 +3185,6 @@ Perl_moreswitches(pTHX_ char *s) return s; case 'A': forbid_setid('A', -1); - if (!PL_preambleav) - PL_preambleav = newAV(); s++; { char * const start = s; @@ -3184,7 +3201,7 @@ Perl_moreswitches(pTHX_ char *s) else if (*s != '\0') { Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start); } - av_push(PL_preambleav, sv); + Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); return s; } case 'M': @@ -3222,9 +3239,7 @@ Perl_moreswitches(pTHX_ char *s) sv_catpvs(sv, "\0)"); } s += strlen(s); - if (!PL_preambleav) - PL_preambleav = newAV(); - av_push(PL_preambleav, sv); + Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); } else Perl_croak(aTHX_ "Missing argument to -%c", *(s-1)); @@ -4676,7 +4691,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register environ[0] = NULL; } if (env) { - char** origenv = environ; char *s; SV *sv; for (; *env; env++) { @@ -4691,11 +4705,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register (void)hv_store(hv, *env, s - *env, sv, 0); if (env_is_not_environ) mg_set(sv); - if (origenv != environ) { - /* realloc has shifted us */ - env = (env - origenv) + environ; - origenv = environ; - } } } #endif /* USE_ENVIRON_ARRAY */ @@ -5107,7 +5116,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { dVAR; SV *atsv; - const line_t oldline = CopLINE(PL_curcop); + const line_t oldline = PL_curcop ? CopLINE(PL_curcop) : 0; CV *cv; STRLEN len; int ret; @@ -5118,21 +5127,15 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) if (PL_savebegin) { if (paramList == PL_beginav) { /* save PL_beginav for compiler */ - if (! PL_beginav_save) - PL_beginav_save = newAV(); - av_push(PL_beginav_save, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_beginav_save, (SV*)cv); } else if (paramList == PL_checkav) { /* save PL_checkav for compiler */ - if (! PL_checkav_save) - PL_checkav_save = newAV(); - av_push(PL_checkav_save, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_checkav_save, (SV*)cv); } else if (paramList == PL_unitcheckav) { /* save PL_unitcheckav for compiler */ - if (! PL_unitcheckav_save) - PL_unitcheckav_save = newAV(); - av_push(PL_unitcheckav_save, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, (SV*)cv); } } else { if (!PL_madskills)