X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=834dc46676b330af7c0810806e708eb036b5ffaa;hb=adbebc0b48cadbf7319b9fc2090fadc929baf733;hp=f199e4656fa307123540823f625df3c469132fcd;hpb=551a8b838dd0aec11f1a7553b070651ef7bd1a24;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index f199e46..834dc46 100644 --- a/perl.c +++ b/perl.c @@ -253,9 +253,10 @@ perl_construct(pTHXx) if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1); s = (U8*)SvPVX(PL_patchlevel); - s = uv_to_utf8(s, (UV)PERL_REVISION); - s = uv_to_utf8(s, (UV)PERL_VERSION); - s = uv_to_utf8(s, (UV)PERL_SUBVERSION); + /* Build version strings using "native" characters */ + s = uvchr_to_utf8(s, (UV)PERL_REVISION); + s = uvchr_to_utf8(s, (UV)PERL_VERSION); + s = uvchr_to_utf8(s, (UV)PERL_SUBVERSION); *s = '\0'; SvCUR_set(PL_patchlevel, s - (U8*)SvPVX(PL_patchlevel)); SvPOK_on(PL_patchlevel); @@ -299,7 +300,6 @@ void perl_destruct(pTHXx) { int destruct_level; /* 0=none, 1=full, 2=full with checks */ - I32 last_sv_count; HV *hv; #ifdef USE_THREADS Thread t; @@ -395,6 +395,7 @@ perl_destruct(pTHXx) LEAVE; FREETMPS; + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -409,6 +410,13 @@ perl_destruct(pTHXx) PL_main_cv = Nullcv; PL_dirty = TRUE; + /* Tell PerlIO we are about to tear things apart in case + we have layers which are using resources that should + be cleaned up now. + */ + + PerlIO_destruct(aTHX); + if (PL_sv_objcount) { /* * Try to destruct global references. We do this first so that the @@ -445,8 +453,9 @@ perl_destruct(pTHXx) I32 i; for (i = 0; environ[i]; i++) - Safefree(environ[i]); - Safefree(environ); + safesysfree(environ[i]); + /* Must use safesysfree() when working with environ. */ + safesysfree(environ); environ = PL_origenviron; } @@ -661,13 +670,13 @@ perl_destruct(pTHXx) } /* Now absolutely destruct everything, somehow or other, loops or no. */ - last_sv_count = 0; SvFLAGS(PL_fdpid) |= SVTYPEMASK; /* don't clean out pid table now */ SvFLAGS(PL_strtab) |= SVTYPEMASK; /* don't clean out strtab now */ - while (PL_sv_count != 0 && PL_sv_count != last_sv_count) { - last_sv_count = PL_sv_count; - sv_clean_all(); - } + + /* the 2 is for PL_fdpid and PL_strtab */ + while (PL_sv_count > 2 && sv_clean_all()) + ; + SvFLAGS(PL_fdpid) &= ~SVTYPEMASK; SvFLAGS(PL_fdpid) |= SVt_PVAV; SvFLAGS(PL_strtab) &= ~SVTYPEMASK; @@ -744,6 +753,7 @@ perl_destruct(pTHXx) Safefree(PL_op_mask); Safefree(PL_psig_ptr); Safefree(PL_psig_name); + Safefree(PL_bitcount); Safefree(PL_psig_pend); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ @@ -1975,10 +1985,11 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* =for apidoc p||require_pv -Tells Perl to C a module. +Tells Perl to C the file named by the string argument. It is +analogous to the Perl code C. It's even +implemented that way; consider using Perl_load_module instead. -=cut -*/ +=cut */ void Perl_require_pv(pTHX_ const char *pv) @@ -2124,7 +2135,8 @@ Perl_moreswitches(pTHX_ char *s) #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { - static char debopts[] = "psltocPmfrxuLHXDST"; + /* if adding extra options, remember to update DEBUG_MASK */ + static char debopts[] = "psltocPmfrxuLHXDSTR"; char *d; for (s++; *s && (d = strchr(debopts,*s)); s++) @@ -2134,7 +2146,7 @@ Perl_moreswitches(pTHX_ char *s) PL_debug = atoi(s+1); for (s++; isDIGIT(*s); s++) ; } - PL_debug |= 0x80000000; + PL_debug |= DEBUG_TOP_FLAG; #else if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ WARN_DEBUGGING, @@ -3244,6 +3256,7 @@ S_init_predump_symbols(pTHX) PL_stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(PL_stdingv); io = GvIOp(PL_stdingv); + IoTYPE(io) = IoTYPE_RDONLY; IoIFP(io) = PerlIO_stdin(); tmpgv = gv_fetchpv("stdin",TRUE, SVt_PV); GvMULTI_on(tmpgv); @@ -3252,6 +3265,7 @@ S_init_predump_symbols(pTHX) tmpgv = gv_fetchpv("STDOUT",TRUE, SVt_PVIO); GvMULTI_on(tmpgv); io = GvIOp(tmpgv); + IoTYPE(io) = IoTYPE_WRONLY; IoOFP(io) = IoIFP(io) = PerlIO_stdout(); setdefout(tmpgv); tmpgv = gv_fetchpv("stdout",TRUE, SVt_PV); @@ -3261,6 +3275,7 @@ S_init_predump_symbols(pTHX) PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO); GvMULTI_on(PL_stderrgv); io = GvIOp(PL_stderrgv); + IoTYPE(io) = IoTYPE_WRONLY; IoOFP(io) = IoIFP(io) = PerlIO_stderr(); tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV); GvMULTI_on(tmpgv); @@ -3354,15 +3369,18 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register #ifdef NEED_ENVIRON_DUP_FOR_MODIFY { char **env_base; - for (env_base = env; *env; env++) + for (env_base = env; *env; env++) dup_env_count++; if ((dup_env_base = (char **) - safemalloc( sizeof(char *) * (dup_env_count+1) ))) { + safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) { char **dup_env; for (env = env_base, dup_env = dup_env_base; *env; - env++, dup_env++) - *dup_env = savepv(*env); + env++, dup_env++) { + /* With environ one needs to use safesysmalloc(). */ + *dup_env = safesysmalloc(strlen(*env) + 1); + (void)strcpy(*dup_env, *env); + } *dup_env = Nullch; env = dup_env_base; } /* else what? */ @@ -3378,17 +3396,15 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register sv = newSVpv(s--,0); (void)hv_store(hv, *env, s - *env, sv, 0); *s = '='; -#if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV) - /* Sins of the RTL. See note in my_setenv(). */ - (void)PerlEnv_putenv(savepv(*env)); -#endif } +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY if (dup_env_base) { char **dup_env; for (dup_env = dup_env_base; *dup_env; dup_env++) - Safefree(*dup_env); - Safefree(dup_env_base); + safesysfree(*dup_env); + safesysfree(dup_env_base); } +#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ #endif /* USE_ENVIRON_ARRAY */ #ifdef DYNAMIC_ENV_FETCH HvNAME(hv) = savepv(ENV_HV_NAME);