X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/95b63a389ed86efed1a2fa9fd24931d56aac6070..61626fd500e6d4ce66fd252d4006308416a874bb:/perl.c diff --git a/perl.c b/perl.c index fc95e83..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); } } @@ -245,7 +250,7 @@ void perl_construct(pTHXx) { dVAR; - PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(my_perl); #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -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 @@ -452,7 +457,7 @@ Perl_dump_sv_child(pTHX_ SV *sv) it to dump out to. We can't let it hold open the file descriptor when it forks, as the file descriptor it will dump to can turn out to be one end of pipe that some other process will wait on for EOF. (So as it would - be open, the wait would be forever. */ + be open, the wait would be forever.) */ msg.msg_control = control.control; msg.msg_controllen = sizeof(control.control); @@ -539,13 +544,13 @@ int perl_destruct(pTHXx) { dVAR; - volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */ + VOL int destruct_level; /* 0=none, 1=full, 2=full with checks */ HV *hv; #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP pid_t child; #endif - PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(my_perl); /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -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); @@ -881,6 +890,11 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_rsfp_filters); PL_rsfp_filters = NULL; + if (PL_minus_F) { + Safefree(PL_splitstr); + PL_splitstr = NULL; + } + /* switches */ PL_preprocess = FALSE; PL_minus_n = FALSE; @@ -944,12 +958,16 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_endav); SvREFCNT_dec(PL_checkav); SvREFCNT_dec(PL_checkav_save); + SvREFCNT_dec(PL_unitcheckav); + SvREFCNT_dec(PL_unitcheckav_save); SvREFCNT_dec(PL_initav); PL_beginav = NULL; PL_beginav_save = NULL; PL_endav = NULL; PL_checkav = NULL; PL_checkav_save = NULL; + PL_unitcheckav = NULL; + PL_unitcheckav_save = NULL; PL_initav = NULL; /* shortcuts just get cleared */ @@ -1053,11 +1071,8 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = NULL; - if (!specialCopIO(PL_compiling.cop_io)) - SvREFCNT_dec(PL_compiling.cop_io); - PL_compiling.cop_io = NULL; - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints); - PL_compiling.cop_hints = NULL; + Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); + PL_compiling.cop_hints_hash = NULL; CopFILE_free(&PL_compiling); CopSTASH_free(&PL_compiling); @@ -1193,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", @@ -1316,6 +1331,11 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { + dVAR; + + if (PL_veto_cleanup) + return; + #ifdef PERL_TRACK_MEMPOOL { /* @@ -1372,7 +1392,7 @@ __attribute__((destructor)) perl_fini(void) { dVAR; - if (PL_curinterp) + if (PL_curinterp && !PL_veto_cleanup) FREE_THREAD_KEY; } @@ -1457,7 +1477,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) int ret; dJMPENV; - PERL_UNUSED_VAR(my_perl); + PERL_UNUSED_ARG(my_perl); #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID @@ -1536,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 && @@ -1550,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 @@ -1573,6 +1591,8 @@ setuid perl scripts securely.\n"); } } } +#endif /* !defined(PERL_USE_SAFE_PUTENV) */ + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } @@ -1608,6 +1628,8 @@ setuid perl scripts securely.\n"); switch (ret) { case 0: parse_body(env,xsinit); + if (PL_unitcheckav) + call_list(oldscope, PL_unitcheckav); if (PL_checkav) call_list(oldscope, PL_checkav); ret = 0; @@ -1621,6 +1643,8 @@ setuid perl scripts securely.\n"); LEAVE; FREETMPS; PL_curstash = PL_defstash; + if (PL_unitcheckav) + call_list(oldscope, PL_unitcheckav); if (PL_checkav) call_list(oldscope, PL_checkav); ret = STATUS_EXIT; @@ -1644,7 +1668,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) VOL bool dosearch = FALSE; const char *validarg = ""; register SV *sv; - register char *s; + register char *s, c; const char *cddir = NULL; #ifdef USE_SITECUSTOMIZE bool minus_f = FALSE; @@ -1672,7 +1696,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif s = argv[0]+1; reswitch: - switch (*s) { + switch ((c = *s)) { case 'C': #ifndef PERL_STRICT_CR case '\r': @@ -1739,7 +1763,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) argc--,argv++; } else - Perl_croak(aTHX_ "No code specified for -%c", *s); + Perl_croak(aTHX_ "No code specified for -%c", c); sv_catpvs(PL_e_script, "\n"); break; @@ -1781,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; @@ -2045,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) { @@ -2297,7 +2311,7 @@ perl_run(pTHXx) int ret = 0; dJMPENV; - PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(my_perl); oldscope = PL_scopestack_ix; #ifdef VMS @@ -2468,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. */ /* @@ -2579,7 +2606,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) LOGOP myop; /* fake syntax tree node */ UNOP method_op; I32 oldmark; - volatile I32 retval = 0; + VOL I32 retval = 0; I32 oldscope; bool oldcatch = CATCH_GET; int ret; @@ -2706,8 +2733,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) dVAR; dSP; UNOP myop; /* fake syntax tree node */ - volatile I32 oldmark = SP - PL_stack_base; - volatile I32 retval = 0; + VOL I32 oldmark = SP - PL_stack_base; + VOL I32 retval = 0; int ret; OP* const oldop = PL_op; dJMPENV; @@ -2936,7 +2963,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) int i = 0; if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq"; for (; isALNUM(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3158,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; @@ -3176,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': @@ -3214,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)); @@ -3265,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__)); @@ -3290,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" @@ -3367,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': @@ -3481,7 +3505,6 @@ S_init_interp(pTHX) /* As these are inside a structure, PERLVARI isn't capable of initialising them */ - PL_regindent = 0; PL_reg_oldcurpm = PL_reg_curpm = NULL; PL_reg_poscache = PL_reg_starttry = NULL; } @@ -3671,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; @@ -4645,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); @@ -4657,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 @@ -4666,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++) { @@ -4679,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 */ @@ -5051,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); } @@ -5074,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, libdir, *incver); + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, + SVfARG(libdir), *incver); subdir = S_incpush_if_exists(aTHX_ subdir); } } @@ -5096,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; @@ -5107,15 +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 */ + Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, (SV*)cv); } } else { if (!PL_madskills) @@ -5147,11 +5167,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) "%s failed--call queue aborted", paramList == PL_checkav ? "CHECK" : paramList == PL_initav ? "INIT" + : paramList == PL_unitcheckav ? "UNITCHECK" : "END"); while (PL_scopestack_ix > oldscope) LEAVE; JMPENV_POP; - Perl_croak(aTHX_ "%"SVf"", (void*)atsv); + Perl_croak(aTHX_ "%"SVf"", SVfARG(atsv)); } break; case 1: @@ -5175,6 +5196,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) Perl_croak(aTHX_ "%s failed--call queue aborted", paramList == PL_checkav ? "CHECK" : paramList == PL_initav ? "INIT" + : paramList == PL_unitcheckav ? "UNITCHECK" : "END"); } my_exit_jump(); @@ -5198,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;