X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=0151338c851c4ad0d37b91869ab5768f741a24dc;hb=4135c0a0e71788fb84c0608a84dab7d6d320b6e8;hp=a5f4e68b6b23646e9e44a643147f9eb163b9a156;hpb=847a5fae45dac396d0f9e1bb61d5b4ff9d94cdcd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index a5f4e68..0151338 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 @@ -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) { @@ -562,6 +585,7 @@ perl_destruct(pTHXx) #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = Nullch; + SvREFCNT_dec(PL_numeric_radix_sv); #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,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 ? */ @@ -1167,6 +1197,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_tainting = TRUE; else { while (s && *s) { + char *d; while (isSPACE(*s)) s++; if (*s == '-') { @@ -1174,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); } } } @@ -1947,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) @@ -2096,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++) @@ -2106,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, @@ -2263,7 +2303,7 @@ Perl_moreswitches(pTHX_ char *s) "\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(), @@ -2575,6 +2615,9 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) sv_catpvn(sv, "-I", 2); sv_catpv(sv,PRIVLIB_EXP); + DEBUG_P(PerlIO_printf(Perl_debug_log, + "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n", + scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS)); #if defined(MSDOS) || defined(WIN32) Perl_sv_setpvf(aTHX_ cmd, "\ sed %s -e \"/^[^#]/b\" \ @@ -2678,8 +2721,14 @@ sed %s -e \"/^[^#]/b\" \ } #endif #endif +#ifdef IAMSUID + errno = EPERM; + Perl_croak(aTHX_ "Can't open perl script: %s\n", + Strerror(errno)); +#else Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", CopFILE(PL_curcop), Strerror(errno)); +#endif } } @@ -3039,7 +3088,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) { @@ -3216,6 +3265,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); @@ -3224,6 +3274,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); @@ -3233,6 +3284,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); @@ -3251,6 +3303,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) { @@ -3308,7 +3364,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 @@ -3319,6 +3375,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; @@ -3329,12 +3405,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 @@ -3543,13 +3623,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); @@ -3558,7 +3640,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 &&