X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9cbac4c72b52b6fc0e8ad9e0050c6aa0b905a8e7..dc22e1c47de3940a478e7bfe0cdc4ec8d3e322ab:/perl.c diff --git a/perl.c b/perl.c index 8d8dc1f..5951e22 100644 --- a/perl.c +++ b/perl.c @@ -149,7 +149,6 @@ void perl_construct(pTHXx) { #ifdef USE_THREADS - int i; #ifndef FAKE_THREADS struct perl_thread *thr = NULL; #endif /* FAKE_THREADS */ @@ -253,9 +252,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 +299,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 +394,7 @@ perl_destruct(pTHXx) LEAVE; FREETMPS; + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -409,6 +409,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 +445,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,7 +584,7 @@ perl_destruct(pTHXx) #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = Nullch; - SvREFCNT_dec(PL_numeric_radix); + SvREFCNT_dec(PL_numeric_radix_sv); #endif /* clear utf8 character classes */ @@ -647,13 +669,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; @@ -730,6 +752,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 ? */ @@ -764,7 +787,8 @@ perl_destruct(pTHXx) MAGIC* moremagic; for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { moremagic = mg->mg_moremagic; - if (mg->mg_ptr && mg->mg_type != 'g' && mg->mg_len >= 0) + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global + && mg->mg_len >= 0) Safefree(mg->mg_ptr); Safefree(mg); } @@ -792,14 +816,24 @@ perl_free(pTHXx) #if defined(PERL_OBJECT) PerlMem_free(this); #else -# if defined(WIN32) +# if defined(WIN32) || defined(NETWARE) # if defined(PERL_IMPLICIT_SYS) - void *host = w32_internal_host; - if (PerlProc_lasthost()) { + #ifdef NETWARE + void *host = nw_internal_host; + #else + void *host = w32_internal_host; + #endif + #ifndef NETWARE + if (PerlProc_lasthost()) { PerlIO_cleanup(); - } + } + #endif PerlMem_free(aTHXx); - win32_delete_internal_host(host); + #ifdef NETWARE + nw5_delete_internal_host(host); + #else + win32_delete_internal_host(host); + #endif #else PerlIO_cleanup(); PerlMem_free(aTHXx); @@ -940,7 +974,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) AV* comppadlist; register SV *sv; register char *s; - char *cddir = Nullch; + char *popts, *cddir = Nullch; sv_setpvn(PL_linestr,"",0); sv = newSVpvn("",0); /* first used for -I flags */ @@ -1165,14 +1199,16 @@ print \" \\@INC:\\n @INC\\n\";"); #ifndef SECURE_INTERNAL_GETENV !PL_tainting && #endif - (s = PerlEnv_getenv("PERL5OPT"))) + (popts = PerlEnv_getenv("PERL5OPT"))) { + s = savepv(popts); while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') PL_tainting = TRUE; else { while (s && *s) { + char *d; while (isSPACE(*s)) s++; if (*s == '-') { @@ -1180,11 +1216,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); } } } @@ -1263,6 +1306,7 @@ print \" \\@INC:\\n @INC\\n\";"); av_store(comppadlist, 1, (SV*)PL_comppad); CvPADLIST(PL_compcv) = comppadlist; + boot_core_PerlIO(); boot_core_UNIVERSAL(); #ifndef PERL_MICRO boot_core_xsutils(); @@ -1647,7 +1691,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) LOGOP myop; /* fake syntax tree node */ UNOP method_op; I32 oldmark; - I32 retval; + volatile I32 retval = 0; I32 oldscope; bool oldcatch = CATCH_GET; int ret; @@ -1834,8 +1878,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) { dSP; UNOP myop; /* fake syntax tree node */ - I32 oldmark = SP - PL_stack_base; - I32 retval; + volatile I32 oldmark = SP - PL_stack_base; + volatile I32 retval = 0; I32 oldscope; int ret; OP* oldop = PL_op; @@ -1953,10 +1997,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) @@ -1980,7 +2025,7 @@ Perl_magicname(pTHX_ char *sym, char *name, I32 namlen) register GV *gv; if ((gv = gv_fetchpv(sym,TRUE, SVt_PV))) - sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen); + sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen); } STATIC void @@ -2102,7 +2147,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++) @@ -2112,7 +2158,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, @@ -2253,9 +2299,22 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': +#if !defined(DGUX) PerlIO_printf(PerlIO_stdout(), Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s", PL_patchlevel, ARCHNAME)); +#else /* DGUX */ +/* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ "\nThis is perl, version %vd\n", PL_patchlevel)); + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ " built under %s at %s %s\n", + OSNAME, __DATE__, __TIME__)); + PerlIO_printf(PerlIO_stdout(), + Perl_form(aTHX_ " OS Specific Release: %s\n", + OSVERS)); +#endif /* !DGUX */ + #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) PerlIO_printf(PerlIO_stdout(), @@ -2295,7 +2354,7 @@ Perl_moreswitches(pTHX_ char *s) #endif #ifdef MPE PerlIO_printf(PerlIO_stdout(), - "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-1999\n"); + "MPE/iX port Copyright by Mark Klein and Mark Bixby, 1996-2001\n"); #endif #ifdef OEMVS PerlIO_printf(PerlIO_stdout(), @@ -2581,6 +2640,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\" \ @@ -2684,8 +2746,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 } } @@ -3081,6 +3149,9 @@ S_find_beginning(pTHX) while ((s = moreswitches(s))) ; } +#ifdef MACOS_TRADITIONAL + break; +#endif } } } @@ -3222,6 +3293,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); @@ -3230,6 +3302,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); @@ -3239,6 +3312,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); @@ -3257,8 +3331,8 @@ 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 + char **dup_env_base = 0; int dup_env_count = 0; #endif @@ -3318,7 +3392,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, PERL_MAGIC_env); #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 @@ -3332,15 +3406,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? */ @@ -3356,21 +3433,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 } +#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); -#endif } TAINT_NOT; if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))