X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=a931a78a77929cb6cc5b3c6b2bd417529bbd8a33;hb=42182ddc72c02b558a109df83ae68e2b617d560e;hp=2d687be08df45ed44545c804cdd7577b7cede54b;hpb=b36c9a5280aaea0bbed551a2d35c216eab023de4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 2d687be..a931a78 100644 --- a/perl.c +++ b/perl.c @@ -228,7 +228,7 @@ void perl_construct(pTHXx) { dVAR; - PERL_UNUSED_ARG(my_perl); + PERL_UNUSED_CONTEXT; #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -404,6 +404,7 @@ no threads. int Perl_nothreadhook(pTHX) { + PERL_UNUSED_CONTEXT; return 0; } @@ -523,7 +524,7 @@ perl_destruct(pTHXx) pid_t child; #endif - PERL_UNUSED_ARG(my_perl); + PERL_UNUSED_CONTEXT; /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -729,9 +730,9 @@ perl_destruct(pTHXx) PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); } op_free(PL_main_root); - PL_main_root = Nullop; + PL_main_root = NULL; } - PL_main_start = Nullop; + PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; PL_dirty = TRUE; @@ -852,7 +853,7 @@ perl_destruct(pTHXx) if(PL_rsfp) { (void)PerlIO_close(PL_rsfp); - PL_rsfp = Nullfp; + PL_rsfp = NULL; } /* Filters for program text */ @@ -1288,10 +1289,19 @@ void perl_free(pTHXx) { #ifdef PERL_TRACK_MEMPOOL - /* Emulate the PerlHost behaviour of free()ing all memory allocated in this - thread at thread exit. */ - while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)) - safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)); + { + /* + * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero + * value as we're probably hunting memory leaks then + */ + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (!s || atoi(s) == 0) { + /* Emulate the PerlHost behaviour of free()ing all memory allocated in this + thread at thread exit. */ + while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)) + safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)); + } + } #endif #if defined(WIN32) || defined(NETWARE) @@ -1317,11 +1327,11 @@ perl_free(pTHXx) #endif } -#if defined(USE_5005THREADS) || defined(USE_ITHREADS) +#if defined(USE_ITHREADS) /* provide destructors to clean up the thread key when libperl is unloaded */ #ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */ -#if defined(__hpux) && __ux_version > 1020 && !defined(__GNUC__) +#if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__) #pragma fini "perl_fini" #endif @@ -1554,9 +1564,9 @@ setuid perl scripts securely.\n"); if (PL_main_root) { op_free(PL_main_root); - PL_main_root = Nullop; + PL_main_root = NULL; } - PL_main_start = Nullop; + PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; @@ -1790,6 +1800,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef PERL_IMPLICIT_SYS " PERL_IMPLICIT_SYS" # endif +# ifdef PERL_MAD + " PERL_MAD" +# endif # ifdef PERL_MALLOC_WRAP " PERL_MALLOC_WRAP" # endif @@ -1817,9 +1830,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # ifdef THREADS_HAVE_PIDS " THREADS_HAVE_PIDS" # endif -# ifdef USE_5005THREADS - " USE_5005THREADS" -# endif # ifdef USE_64_BIT_ALL " USE_64_BIT_ALL" # endif @@ -2083,11 +2093,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) CvUNIQUE_on(PL_compcv); CvPADLIST(PL_compcv) = pad_new(0); -#ifdef USE_5005THREADS - CvOWNER(PL_compcv) = 0; - Newx(CvMUTEXP(PL_compcv), 1, perl_mutex); - MUTEX_INIT(CvMUTEXP(PL_compcv)); -#endif /* USE_5005THREADS */ boot_core_PerlIO(); boot_core_UNIVERSAL(); @@ -2242,7 +2247,7 @@ perl_run(pTHXx) int ret = 0; dJMPENV; - PERL_UNUSED_ARG(my_perl); + PERL_UNUSED_CONTEXT; oldscope = PL_scopestack_ix; #ifdef VMS @@ -2352,13 +2357,6 @@ SV* Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; -#ifdef USE_5005THREADS - if (name[1] == '\0' && !isALPHA(name[0])) { - PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) - return THREADSV(tmp); - } -#endif /* USE_5005THREADS */ gv = gv_fetchpv(name, create, SVt_PV); if (gv) return GvSV(gv); @@ -2435,8 +2433,7 @@ Perl_get_cv(pTHX_ const char *name, I32 create) if (create && !GvCVu(gv)) return newSUB(start_subparse(FALSE, 0), newSVOP(OP_CONST, 0, newSVpv(name,0)), - Nullop, - Nullop); + NULL, NULL); if (gv) return GvCVu(gv); return NULL; @@ -2539,7 +2536,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) } Zero(&myop, 1, LOGOP); - myop.op_next = Nullop; + myop.op_next = NULL; if (!(flags & G_NOARGS)) myop.op_flags |= OPf_STACKED; myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : @@ -2715,7 +2712,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_NOARGS)) myop.op_flags = OPf_STACKED; - myop.op_next = Nullop; + myop.op_next = NULL; myop.op_type = OP_ENTEREVAL; myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : (flags & G_ARRAY) ? OPf_WANT_LIST : @@ -3046,7 +3043,9 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, start); else { sv_catpvn(sv, start, s-start); - Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); + /* Don't use NUL as q// delimiter here, this string goes in the + * environment. */ + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); } s += strlen(s); my_setenv("PERL5DB", SvPV_nolen_const(sv)); @@ -3403,15 +3402,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); void Perl_my_unexec(pTHX) { + PERL_UNUSED_CONTEXT; #ifdef UNEXEC - SV* prog; - SV* file; + SV * prog = newSVpv(BIN_EXP, 0); + SV * file = newSVpv(PL_origfilename, 0); int status = 1; extern int etext; - prog = newSVpv(BIN_EXP, 0); sv_catpvs(prog, "/perl"); - file = newSVpv(PL_origfilename, 0); sv_catpvs(file, ".perldump"); unexec(SvPVX(file), SvPVX(prog), &etext, sbrk(0), 0); @@ -3438,21 +3436,14 @@ S_init_interp(pTHX) # define PERLVAR(var,type) # define PERLVARA(var,n,type) # if defined(PERL_IMPLICIT_CONTEXT) -# if defined(USE_5005THREADS) -# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; -# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; -# else /* !USE_5005THREADS */ -# define PERLVARI(var,type,init) aTHX->var = init; -# define PERLVARIC(var,type,init) aTHX->var = init; -# endif /* USE_5005THREADS */ +# define PERLVARI(var,type,init) aTHX->var = init; +# define PERLVARIC(var,type,init) aTHX->var = init; # else # define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; # define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; # endif # include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif +# include "thrdvar.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI @@ -3463,9 +3454,7 @@ S_init_interp(pTHX) # define PERLVARI(var,type,init) PL_##var = init; # define PERLVARIC(var,type,init) PL_##var = init; # include "intrpvar.h" -# ifndef USE_5005THREADS -# include "thrdvar.h" -# endif +# include "thrdvar.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI @@ -3492,18 +3481,18 @@ S_init_main_stash(pTHX) of the SvREFCNT_dec, only to add it again with hv_name_set */ SvREFCNT_dec(GvHV(gv)); hv_name_set(PL_defstash, "main", 4, 0); - GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); + GvHV(gv) = (HV*)SvREFCNT_inc_simple(PL_defstash); SvREADONLY_on(gv); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, SVt_PVAV))); - SvREFCNT_inc(PL_incgv); /* Don't allow it to be freed */ + SvREFCNT_inc_simple(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ GvMULTI_on(PL_hintgv); PL_defgv = gv_fetchpvs("_", GV_ADD|GV_NOTQUAL, SVt_PVAV); - SvREFCNT_inc(PL_defgv); + SvREFCNT_inc_simple(PL_defgv); PL_errgv = gv_HVadd(gv_fetchpvs("@", GV_ADD|GV_NOTQUAL, SVt_PV)); - SvREFCNT_inc(PL_errgv); + SvREFCNT_inc_simple(PL_errgv); GvMULTI_on(PL_errgv); PL_replgv = gv_fetchpvs("\022", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); @@ -4220,6 +4209,8 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n"); #endif /* IAMSUID */ #else /* !DOSUID */ + PERL_UNUSED_ARG(fdscript); + PERL_UNUSED_ARG(suidscript); if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ @@ -4234,8 +4225,8 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); /* not set-id, must be wrapped */ } #endif /* DOSUID */ - (void)validarg; - (void)scriptname; + PERL_UNUSED_ARG(validarg); + PERL_UNUSED_ARG(scriptname); } STATIC void @@ -4514,7 +4505,7 @@ S_init_lexer(pTHX) dVAR; PerlIO *tmpfp; tmpfp = PL_rsfp; - PL_rsfp = Nullfp; + PL_rsfp = NULL; lex_start(PL_linestr); PL_rsfp = tmpfp; PL_subname = newSVpvs("main"); @@ -4535,7 +4526,7 @@ S_init_predump_symbols(pTHX) IoIFP(io) = PerlIO_stdin(); tmpgv = gv_fetchpvs("stdin", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); tmpgv = gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(tmpgv); @@ -4545,7 +4536,7 @@ S_init_predump_symbols(pTHX) setdefout(tmpgv); tmpgv = gv_fetchpvs("stdout", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); PL_stderrgv = gv_fetchpvs("STDERR", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stderrgv); @@ -4554,7 +4545,7 @@ S_init_predump_symbols(pTHX) IoOFP(io) = IoIFP(io) = PerlIO_stderr(); tmpgv = gv_fetchpvs("stderr", GV_ADD|GV_NOTQUAL, SVt_PV); GvMULTI_on(tmpgv); - GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io); + GvIOp(tmpgv) = (IO*)SvREFCNT_inc_simple(io); PL_statname = newSV(0); /* last filename we did stat on */ @@ -5073,85 +5064,6 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, } } -#ifdef USE_5005THREADS -STATIC struct perl_thread * -S_init_main_thread(pTHX) -{ -#if !defined(PERL_IMPLICIT_CONTEXT) - struct perl_thread *thr; -#endif - XPV *xpv; - - Newxz(thr, 1, struct perl_thread); - PL_curcop = &PL_compiling; - thr->interp = PERL_GET_INTERP; - thr->cvcache = newHV(); - thr->threadsv = newAV(); - /* thr->threadsvp is set when find_threadsv is called */ - thr->specific = newAV(); - thr->flags = THRf_R_JOINABLE; - MUTEX_INIT(&thr->mutex); - /* Handcraft thrsv similarly to mess_sv */ - Newx(PL_thrsv, 1, SV); - Newxz(xpv, 1, XPV); - SvFLAGS(PL_thrsv) = SVt_PV; - SvANY(PL_thrsv) = (void*)xpv; - SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */ - SvPV_set(PL_thrsvr, (char*)thr); - SvCUR_set(PL_thrsv, sizeof(thr)); - SvLEN_set(PL_thrsv, sizeof(thr)); - *SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */ - thr->oursv = PL_thrsv; - PL_chopset = " \n-"; - PL_dumpindent = 4; - - MUTEX_LOCK(&PL_threads_mutex); - PL_nthreads++; - thr->tid = 0; - thr->next = thr; - thr->prev = thr; - thr->thr_done = 0; - MUTEX_UNLOCK(&PL_threads_mutex); - -#ifdef HAVE_THREAD_INTERN - Perl_init_thread_intern(thr); -#endif - -#ifdef SET_THREAD_SELF - SET_THREAD_SELF(thr); -#else - thr->self = pthread_self(); -#endif /* SET_THREAD_SELF */ - PERL_SET_THX(thr); - - /* - * These must come after the thread self setting - * because sv_setpvn does SvTAINT and the taint - * fields thread selfness being set. - */ - PL_toptarget = newSV(0); - sv_upgrade(PL_toptarget, SVt_PVFM); - sv_setpvn(PL_toptarget, "", 0); - PL_bodytarget = newSV(0); - sv_upgrade(PL_bodytarget, SVt_PVFM); - sv_setpvn(PL_bodytarget, "", 0); - PL_formtarget = PL_bodytarget; - thr->errsv = newSVpvs(""); - (void) find_threadsv("@"); /* Ensure $@ is initialised early */ - - PL_maxscream = -1; - PL_peepp = MEMBER_TO_FPTR(Perl_peep); - PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp); - PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags); - PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start); - PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string); - PL_regfree = MEMBER_TO_FPTR(Perl_pregfree); - PL_regindent = 0; - PL_reginterp_cnt = 0; - - return thr; -} -#endif /* USE_5005THREADS */ void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) @@ -5349,9 +5261,6 @@ STATIC void S_my_exit_jump(pTHX) { dVAR; - register PERL_CONTEXT *cx; - I32 gimme; - SV **newsp; if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -5359,16 +5268,10 @@ S_my_exit_jump(pTHX) } POPSTACK_TO(PL_mainstack); - if (cxstack_ix >= 0) { - if (cxstack_ix > 0) - dounwind(0); - POPBLOCK(cx,PL_curpm); - LEAVE; - } + dounwind(-1); + LEAVE_SCOPE(0); JMPENV_JUMP(2); - PERL_UNUSED_VAR(gimme); - PERL_UNUSED_VAR(newsp); } static I32