X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=7a53b72e74efb7424c91425de304acd412094198;hb=61626fd500e6d4ce66fd252d4006308416a874bb;hp=0f242d73b6b0f580c5be0e1f291c7f89b8e3568e;hpb=47f5682248e332efa01df2dd2d3fe2f6bd0ffc35;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 0f242d7..7a53b72 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; } @@ -792,19 +798,6 @@ perl_destruct(pTHXx) PL_exitlist = NULL; PL_exitlistlen = 0; - if (destruct_level == 0){ - - DEBUG_P(debprofdump()); - -#if defined(PERLIO_LAYERS) - /* No more IO - including error messages ! */ - PerlIO_cleanup(aTHX); -#endif - - /* The exit() function will do everything that needs doing. */ - return STATUS_EXIT; - } - /* jettison our possibly duplicated environment */ /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied * so we certainly shouldn't free it here @@ -831,6 +824,22 @@ perl_destruct(pTHXx) #endif #endif /* !PERL_MICRO */ + if (destruct_level == 0) { + + DEBUG_P(debprofdump()); + +#if defined(PERLIO_LAYERS) + /* No more IO - including error messages ! */ + PerlIO_cleanup(aTHX); +#endif + + CopFILE_free(&PL_compiling); + CopSTASH_free(&PL_compiling); + + /* The exit() function will do everything that needs doing. */ + return STATUS_EXIT; + } + /* reset so print() ends up where we expect */ setdefout(NULL); @@ -1199,7 +1208,7 @@ perl_destruct(pTHXx) " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" "\tallocated at %s:%d %s %s%s\n", - sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE, + (void*)sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", sv->sv_debug_line, sv->sv_debug_inpad ? "for" : "by", @@ -1322,6 +1331,11 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { + dVAR; + + if (PL_veto_cleanup) + return; + #ifdef PERL_TRACK_MEMPOOL { /* @@ -1378,7 +1392,7 @@ __attribute__((destructor)) perl_fini(void) { dVAR; - if (PL_curinterp) + if (PL_curinterp && !PL_veto_cleanup) FREE_THREAD_KEY; } @@ -1542,13 +1556,11 @@ 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 ((PL_origenviron[0] == s + 1 -#ifdef OS2 - || (PL_origenviron[0] == s + 9 && (s += 8)) -#endif - ) + if (s && PL_origenviron && !PL_use_safe_putenv) { + if ((PL_origenviron[0] == s + 1) || (aligned && (PL_origenviron[0] > s && @@ -1556,7 +1568,7 @@ setuid perl scripts securely.\n"); INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) ) { -#ifndef OS2 +#ifndef OS2 /* ENVIRON is read by the kernel too. */ s = PL_origenviron[0]; while (*s) s++; #endif @@ -1579,6 +1591,8 @@ setuid perl scripts securely.\n"); } } } +#endif /* !defined(PERL_USE_SAFE_PUTENV) */ + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } @@ -1791,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; @@ -2055,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) { @@ -2478,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. */ /* @@ -3168,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; @@ -3186,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': @@ -3224,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)); @@ -3275,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", - vstringify(PL_patchlevel))); + SVfARG(vstringify(PL_patchlevel)))); PerlIO_printf(PerlIO_stdout(), Perl_form(aTHX_ " built under %s at %s %s\n", OSNAME, __DATE__, __TIME__)); @@ -3300,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" @@ -3377,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': @@ -3680,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; @@ -4654,6 +4668,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { HV *hv; + bool env_is_not_environ; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); hv_magic(hv, NULL, PERL_MAGIC_env); @@ -4666,7 +4681,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register */ if (!env) env = environ; - if (env != environ + env_is_not_environ = env != environ; + if (env_is_not_environ # ifdef USE_ITHREADS && PL_curinterp == aTHX # endif @@ -4675,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++) { @@ -4688,13 +4703,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register #endif sv = newSVpv(s+1, 0); (void)hv_store(hv, *env, s - *env, sv, 0); - if (env != environ) + 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 */ @@ -5060,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); } @@ -5083,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); } } @@ -5105,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; @@ -5116,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) @@ -5167,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: @@ -5215,7 +5220,7 @@ Perl_my_exit(pTHX_ U32 status) { dVAR; DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", - thr, (unsigned long) status)); + (void*)thr, (unsigned long) status)); switch (status) { case 0: STATUS_ALL_SUCCESS;