X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=834dc46676b330af7c0810806e708eb036b5ffaa;hb=e71c662575b0eacf7e7e6e47ee6a2e23313ee8e7;hp=308d0d31c61390a69df3b481ab0c0856656ca543;hpb=5b3035ed4d02db655cf5d2d62ab1ebb11c131def;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 308d0d3..834dc46 100644 --- a/perl.c +++ b/perl.c @@ -1,6 +1,6 @@ /* perl.c * - * Copyright (c) 1987-2000 Larry Wall + * Copyright (c) 1987-2001 Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -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 @@ -438,6 +446,21 @@ perl_destruct(pTHXx) return; } + /* jettison our possibly duplicated environment */ + +#ifdef USE_ENVIRON_ARRAY + if (environ != PL_origenviron) { + I32 i; + + for (i = 0; environ[i]; i++) + safesysfree(environ[i]); + /* Must use safesysfree() when working with environ. */ + safesysfree(environ); + + environ = PL_origenviron; + } +#endif + /* loosen bonds of global variables */ if(PL_rsfp) { @@ -473,11 +496,11 @@ perl_destruct(pTHXx) /* magical thingies */ - Safefree(PL_ofs); /* $, */ - PL_ofs = Nullch; + SvREFCNT_dec(PL_ofs_sv); /* $, */ + PL_ofs_sv = Nullsv; - Safefree(PL_ors); /* $\ */ - PL_ors = Nullch; + SvREFCNT_dec(PL_ors_sv); /* $\ */ + PL_ors_sv = Nullsv; SvREFCNT_dec(PL_rs); /* $/ */ PL_rs = Nullsv; @@ -562,6 +585,7 @@ perl_destruct(pTHXx) #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = Nullch; + SvREFCNT_dec(PL_numeric_radix); #endif /* clear utf8 character classes */ @@ -646,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; @@ -697,6 +721,11 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); +#ifdef USE_ITHREADS + /* free the pointer table used for cloning */ + ptr_table_free(PL_ptr_table); +#endif + /* free special SVs */ SvREFCNT(&PL_sv_yes) = 0; @@ -724,6 +753,8 @@ 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 ? */ @@ -785,12 +816,18 @@ perl_free(pTHXx) #if defined(PERL_OBJECT) PerlMem_free(this); #else -# if defined(PERL_IMPLICIT_SYS) && defined(WIN32) +# if defined(WIN32) +# if defined(PERL_IMPLICIT_SYS) void *host = w32_internal_host; - if (PerlProc_lasthost()) - PerlIO_cleanup(); + if (PerlProc_lasthost()) { + PerlIO_cleanup(); + } PerlMem_free(aTHXx); win32_delete_internal_host(host); +#else + PerlIO_cleanup(); + PerlMem_free(aTHXx); +#endif # else PerlMem_free(aTHXx); # endif @@ -1160,6 +1197,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_tainting = TRUE; else { while (s && *s) { + char *d; while (isSPACE(*s)) s++; if (*s == '-') { @@ -1167,11 +1205,18 @@ print \" \\@INC:\\n @INC\\n\";"); if (isSPACE(*s)) continue; } + d = s; if (!*s) break; if (!strchr("DIMUdmw", *s)) Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); - s = moreswitches(s); + while (++s && *s) { + if (isSPACE(*s)) { + *s++ = '\0'; + break; + } + } + moreswitches(d); } } } @@ -1940,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) @@ -2089,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++) @@ -2099,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, @@ -2152,23 +2199,23 @@ Perl_moreswitches(pTHX_ char *s) case 'l': PL_minus_l = TRUE; s++; - if (PL_ors) - Safefree(PL_ors); + if (PL_ors_sv) { + SvREFCNT_dec(PL_ors_sv); + PL_ors_sv = Nullsv; + } if (isDIGIT(*s)) { - PL_ors = savepv("\n"); - PL_orslen = 1; + PL_ors_sv = newSVpvn("\n",1); numlen = 0; /* disallow underscores */ - *PL_ors = (char)scan_oct(s, 3 + (*s == '0'), &numlen); + *SvPVX(PL_ors_sv) = (char)scan_oct(s, 3 + (*s == '0'), &numlen); s += numlen; } else { if (RsPARA(PL_nrs)) { - PL_ors = "\n\n"; - PL_orslen = 2; + PL_ors_sv = newSVpvn("\n\n",2); + } + else { + PL_ors_sv = newSVsv(PL_nrs); } - else - PL_ors = SvPV(PL_nrs, PL_orslen); - PL_ors = savepvn(PL_ors, PL_orslen); } return s; case 'M': @@ -2253,10 +2300,10 @@ Perl_moreswitches(pTHX_ char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2000, Larry Wall\n"); + "\n\nCopyright 1987-2001, Larry Wall\n"); #ifdef MACOS_TRADITIONAL PerlIO_printf(PerlIO_stdout(), - "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n"); + "\nMac OS port Copyright (c) 1991-2001, Matthias Neeracher\n"); #endif #ifdef MSDOS PerlIO_printf(PerlIO_stdout(), @@ -3032,7 +3079,7 @@ S_find_beginning(pTHX) forbid_setid("-x"); #ifdef MACOS_TRADITIONAL - /* Since the Mac OS does not honor !# arguments for us, we do it ourselves */ + /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */ while (PL_doextract || gMacPerl_AlwaysExtract) { if ((s = sv_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { @@ -3209,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); @@ -3217,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); @@ -3226,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); @@ -3244,6 +3294,10 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char *s; SV *sv; GV* tmpgv; + char **dup_env_base = 0; +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + int dup_env_count = 0; +#endif argc--,argv++; /* skip name of script */ if (PL_doswitches) { @@ -3301,7 +3355,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register HV *hv; GvMULTI_on(PL_envgv); hv = GvHVn(PL_envgv); - hv_magic(hv, PL_envgv, 'E'); + hv_magic(hv, Nullgv, 'E'); #ifdef USE_ENVIRON_ARRAY /* Note that if the supplied env parameter is actually a copy of the global environ then it may now point to free'd memory @@ -3312,6 +3366,26 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register env = environ; if (env != environ) environ[0] = Nullch; +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + { + char **env_base; + for (env_base = env; *env; env++) + dup_env_count++; + if ((dup_env_base = (char **) + safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) { + char **dup_env; + for (env = env_base, dup_env = dup_env_base; + *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? */ + } +#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */ for (; *env; env++) { if (!(s = strchr(*env,'='))) continue; @@ -3322,12 +3396,16 @@ 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 } -#endif +#ifdef NEED_ENVIRON_DUP_FOR_MODIFY + if (dup_env_base) { + char **dup_env; + for (dup_env = dup_env_base; *dup_env; dup_env++) + 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); #endif @@ -3536,13 +3614,15 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) if (addsubdirs) { #ifdef MACOS_TRADITIONAL #define PERL_AV_SUFFIX_FMT "" -#define PERL_ARCH_FMT ":%s" +#define PERL_ARCH_FMT "%s:" +#define PERL_ARCH_FMT_PATH PERL_FS_VER_FMT PERL_AV_SUFFIX_FMT #else #define PERL_AV_SUFFIX_FMT "/" #define PERL_ARCH_FMT "/%s" +#define PERL_ARCH_FMT_PATH PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT #endif /* .../version/archname if -d .../version/archname */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT PERL_ARCH_FMT, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION, ARCHNAME); @@ -3551,7 +3631,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers) av_push(GvAVn(PL_incgv), newSVsv(subdir)); /* .../version if -d .../version */ - Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_AV_SUFFIX_FMT PERL_FS_VER_FMT, libdir, + Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir, (int)PERL_REVISION, (int)PERL_VERSION, (int)PERL_SUBVERSION); if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&