X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=fa1407fa2d75e3c2092d61a26c380265950c911e;hb=1fef4616ad97a72dc45194bd8ac11e63e518aba2;hp=480619fb7980ae118dabbd40fe460b4df09bdf7b;hpb=6c9570dc5de7137a22f5d4e76431529d4f7342b7;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 480619f..fa1407f 100644 --- a/perl.c +++ b/perl.c @@ -1,7 +1,7 @@ /* perl.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -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 @@ -580,6 +585,7 @@ perl_destruct(pTHXx) if (CALL_FPTR(PL_threadhook)(aTHX)) { /* Threads hook has vetoed further cleanup */ + PL_veto_cleanup = TRUE; return STATUS_EXIT; } @@ -1325,6 +1331,11 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { + dVAR; + + if (PL_veto_cleanup) + return; + #ifdef PERL_TRACK_MEMPOOL { /* @@ -1381,7 +1392,7 @@ __attribute__((destructor)) perl_fini(void) { dVAR; - if (PL_curinterp) + if (PL_curinterp && !PL_veto_cleanup) FREE_THREAD_KEY; } @@ -1545,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 && @@ -1578,6 +1591,8 @@ setuid perl scripts securely.\n"); } } } +#endif /* !defined(PERL_USE_SAFE_PUTENV) */ + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } @@ -1790,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; @@ -2054,18 +2066,11 @@ 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 - if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) { - PL_compiling.cop_warnings - = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize); - } - if (!scriptname) scriptname = argv[0]; if (PL_e_script) { @@ -2477,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. */ /* @@ -3167,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; @@ -3185,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': @@ -3223,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)); @@ -3274,13 +3288,13 @@ Perl_moreswitches(pTHX_ char *s) " DEVEL" STRINGIFY(PERL_PATCHNUM) #endif " built for %s", - (void*)vstringify(PL_patchlevel), + SVfARG(vstringify(PL_patchlevel)), ARCHNAME)); #else /* DGUX */ /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ PerlIO_printf(PerlIO_stdout(), Perl_form(aTHX_ "\nThis is perl, %"SVf"\n", - (void*)vstringify(PL_patchlevel))); + SVfARG(vstringify(PL_patchlevel)))); PerlIO_printf(PerlIO_stdout(), Perl_form(aTHX_ " built under %s at %s %s\n", OSNAME, __DATE__, __TIME__)); @@ -3299,7 +3313,7 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2006, Larry Wall\n"); + "\n\nCopyright 1987-2007, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), "\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n" @@ -3376,8 +3390,9 @@ this system using \"man perl\" or \"perldoc perl\". If you have access to the\n Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); my_exit(0); case 'w': - if (! (PL_dowarn & G_WARN_ALL_MASK)) + if (! (PL_dowarn & G_WARN_ALL_MASK)) { PL_dowarn |= G_WARN_ON; + } s++; return s; case 'W': @@ -3679,8 +3694,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, Perl_sv_setpvf(aTHX_ cmd, "\ %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s", - perl, quote, code, quote, scriptname, (void*)cpp, - cpp_discard_flag, (void*)sv, CPPMINUS); + perl, quote, code, quote, scriptname, SVfARG(cpp), + cpp_discard_flag, SVfARG(sv), CPPMINUS); PL_doextract = FALSE; @@ -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 */ @@ -5061,21 +5070,21 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, #endif /* .../version/archname if -d .../version/archname */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, - (void*)libdir, + SVfARG(libdir), (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); subdir = S_incpush_if_exists(aTHX_ subdir); /* .../version if -d .../version */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, - (void*)libdir, + SVfARG(libdir), (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); subdir = S_incpush_if_exists(aTHX_ subdir); /* .../archname if -d .../archname */ Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, - (void*)libdir, ARCHNAME); + SVfARG(libdir), ARCHNAME); subdir = S_incpush_if_exists(aTHX_ subdir); } @@ -5084,7 +5093,8 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, if (addoldvers) { for (incver = incverlist; *incver; incver++) { /* .../xxx if -d .../xxx */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, (void *)libdir, *incver); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, + SVfARG(libdir), *incver); subdir = S_incpush_if_exists(aTHX_ subdir); } } @@ -5117,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) @@ -5168,7 +5172,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (PL_scopestack_ix > oldscope) LEAVE; JMPENV_POP; - Perl_croak(aTHX_ "%"SVf"", (void*)atsv); + Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv)); } break; case 1: