X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=0151338c851c4ad0d37b91869ab5768f741a24dc;hb=4135c0a0e71788fb84c0608a84dab7d6d320b6e8;hp=f1cda0e8290485608f2927c2a7a6da60a0f02dbe;hpb=5f1a76d08cedee4f2888d077fe9593b03dd9bd13;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index f1cda0e..0151338 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); @@ -298,9 +299,7 @@ Shuts down a Perl interpreter. See L. void perl_destruct(pTHXx) { - dTHR; int destruct_level; /* 0=none, 1=full, 2=full with checks */ - I32 last_sv_count; HV *hv; #ifdef USE_THREADS Thread t; @@ -396,6 +395,7 @@ perl_destruct(pTHXx) LEAVE; FREETMPS; + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -410,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 @@ -439,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) { @@ -474,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; @@ -563,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 */ @@ -647,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; @@ -698,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; @@ -725,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 ? */ @@ -786,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 @@ -818,7 +854,6 @@ Tells a Perl interpreter to parse a Perl script. See L. int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { - dTHR; I32 oldscope; int ret; dJMPENV; @@ -920,7 +955,6 @@ S_vparse_body(pTHX_ va_list args) STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { - dTHR; int argc = PL_origargc; char **argv = PL_origargv; char *scriptname = NULL; @@ -1163,6 +1197,7 @@ print \" \\@INC:\\n @INC\\n\";"); PL_tainting = TRUE; else { while (s && *s) { + char *d; while (isSPACE(*s)) s++; if (*s == '-') { @@ -1170,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); } } } @@ -1351,7 +1393,6 @@ Tells a Perl interpreter to run. See L. int perl_run(pTHXx) { - dTHR; I32 oldscope; int ret = 0; dJMPENV; @@ -1419,8 +1460,6 @@ S_vrun_body(pTHX_ va_list args) STATIC void * S_run_body(pTHX_ I32 oldscope) { - dTHR; - DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); @@ -1479,10 +1518,8 @@ Perl_get_sv(pTHX_ const char *name, I32 create) #ifdef USE_THREADS if (name[1] == '\0' && !isALPHA(name[0])) { PADOFFSET tmp = find_threadsv(name); - if (tmp != NOT_IN_PAD) { - dTHR; + if (tmp != NOT_IN_PAD) return THREADSV(tmp); - } } #endif /* USE_THREADS */ gv = gv_fetchpv(name, create, SVt_PV); @@ -1802,8 +1839,6 @@ S_vcall_body(pTHX_ va_list args) STATIC void S_call_body(pTHX_ OP *myop, int is_eval) { - dTHR; - if (PL_op == myop) { if (is_eval) PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ @@ -1950,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) @@ -2036,7 +2072,6 @@ Perl_moreswitches(pTHX_ char *s) switch (*s) { case '0': { - dTHR; numlen = 0; /* disallow underscores */ rschar = (U32)scan_oct(s, 4, &numlen); SvREFCNT_dec(PL_nrs); @@ -2100,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++) @@ -2110,9 +2146,8 @@ Perl_moreswitches(pTHX_ char *s) PL_debug = atoi(s+1); for (s++; isDIGIT(*s); s++) ; } - PL_debug |= 0x80000000; + PL_debug |= DEBUG_TOP_FLAG; #else - dTHR; if (ckWARN_d(WARN_DEBUGGING)) Perl_warner(aTHX_ WARN_DEBUGGING, "Recompile perl with -DDEBUGGING to use -D switch\n"); @@ -2164,24 +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 { - dTHR; 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': @@ -2266,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(), @@ -2489,7 +2523,6 @@ S_init_interp(pTHX) STATIC void S_init_main_stash(pTHX) { - dTHR; GV *gv; /* Note that strtab is a rather special HV. Assumptions are made @@ -2533,8 +2566,6 @@ S_init_main_stash(pTHX) STATIC void S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) { - dTHR; - *fdscript = -1; if (PL_e_script) { @@ -2584,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\" \ @@ -2687,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 } } @@ -2828,7 +2868,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) */ #ifdef DOSUID - dTHR; char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */ @@ -3026,7 +3065,6 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); #else /* !DOSUID */ if (PL_euid != PL_uid || PL_egid != PL_gid) { /* (suidperl doesn't exist, in fact) */ #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW - dTHR; PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf); /* may be either wrapped or real suid */ if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID) || @@ -3050,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) { @@ -3117,7 +3155,6 @@ S_forbid_setid(pTHX_ char *s) void Perl_init_debugger(pTHX) { - dTHR; HV *ostash = PL_curstash; PL_curstash = PL_debstash; @@ -3185,7 +3222,6 @@ Perl_init_stacks(pTHX) STATIC void S_nuke_stacks(pTHX) { - dTHR; while (PL_curstackinfo->si_next) PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { @@ -3222,7 +3258,6 @@ S_init_lexer(pTHX) STATIC void S_init_predump_symbols(pTHX) { - dTHR; GV *tmpgv; IO *io; @@ -3230,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); @@ -3238,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); @@ -3247,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); @@ -3262,10 +3300,13 @@ S_init_predump_symbols(pTHX) STATIC void S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env) { - dTHR; 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) { @@ -3323,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 @@ -3334,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; @@ -3344,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 @@ -3558,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); @@ -3573,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 && @@ -3657,8 +3724,9 @@ S_init_main_thread(pTHX) PERL_SET_THX(thr); /* - * These must come after the SET_THR because sv_setpvn does - * SvTAINT and the taint fields require dTHR. + * 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,0); sv_upgrade(PL_toptarget, SVt_PVFM); @@ -3686,7 +3754,6 @@ S_init_main_thread(pTHX) void Perl_call_list(pTHX_ I32 oldscope, AV *paramList) { - dTHR; SV *atsv; line_t oldline = CopLINE(PL_curcop); CV *cv; @@ -3791,8 +3858,6 @@ S_call_list_body(pTHX_ CV *cv) void Perl_my_exit(pTHX_ U32 status) { - dTHR; - DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", thr, (unsigned long) status)); switch (status) { @@ -3841,7 +3906,6 @@ Perl_my_failure_exit(pTHX) STATIC void S_my_exit_jump(pTHX) { - dTHR; register PERL_CONTEXT *cx; I32 gimme; SV **newsp;