X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=cb2cb14db54eed11252e555f4ee325e53912e5f3;hb=880b20b67e23950959b9017ea50a2f9fe4e915a4;hp=81287331c05c7e4181f459e269f059fac61ae91b;hpb=bf4acbe410c9fcc2bff9bfa63411be8c6c46902a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 8128733..cb2cb14 100644 --- a/perl.c +++ b/perl.c @@ -180,6 +180,8 @@ perl_construct(pTHXx) # endif /* EMULATE_ATOMIC_REFCOUNTS */ MUTEX_INIT(&PL_cred_mutex); + MUTEX_INIT(&PL_sv_lock_mutex); + MUTEX_INIT(&PL_fdpid_mutex); thr = init_main_thread(); #endif /* USE_THREADS */ @@ -375,6 +377,7 @@ perl_destruct(pTHXx) DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n")); MUTEX_DESTROY(&PL_threads_mutex); COND_DESTROY(&PL_nthreads_cond); + PL_nthreads--; #endif /* !defined(FAKE_THREADS) */ #endif /* USE_THREADS */ @@ -600,9 +603,14 @@ perl_destruct(pTHXx) if (!specialWARN(PL_compiling.cop_warnings)) SvREFCNT_dec(PL_compiling.cop_warnings); PL_compiling.cop_warnings = Nullsv; -#ifndef USE_ITHREADS +#ifdef USE_ITHREADS + Safefree(CopFILE(&PL_compiling)); + CopFILE(&PL_compiling) = Nullch; + Safefree(CopSTASHPV(&PL_compiling)); +#else SvREFCNT_dec(CopFILEGV(&PL_compiling)); - CopFILEGV_set(&PL_compiling, Nullgv); + CopFILEGV(&PL_compiling) = Nullgv; + /* cop_stash is not refcounted */ #endif /* Prepare to destruct main symbol table. */ @@ -652,6 +660,10 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_fdpid); /* needed in io_close() */ PL_fdpid = Nullav; +#ifdef HAVE_INTERP_INTERN + sys_intern_clear(); +#endif + /* Destruct the global string table. */ { /* Yell and reset the HeVAL() slots that are still holding refcounts, @@ -701,9 +713,6 @@ perl_destruct(pTHXx) if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); - sv_free_arenas(); - - /* No SVs have survived, need to clean out */ Safefree(PL_origfilename); Safefree(PL_reg_start_tmp); if (PL_reg_curpm) @@ -711,6 +720,8 @@ perl_destruct(pTHXx) Safefree(PL_reg_poscache); Safefree(HeKEY_hek(&PL_hv_fetch_ent_mh)); Safefree(PL_op_mask); + Safefree(PL_psig_ptr); + Safefree(PL_psig_name); nuke_stacks(); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ @@ -720,6 +731,7 @@ perl_destruct(pTHXx) MUTEX_DESTROY(&PL_sv_mutex); MUTEX_DESTROY(&PL_eval_mutex); MUTEX_DESTROY(&PL_cred_mutex); + MUTEX_DESTROY(&PL_fdpid_mutex); COND_DESTROY(&PL_eval_cond); #ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_DESTROY(&PL_svref_mutex); @@ -732,6 +744,8 @@ perl_destruct(pTHXx) PL_thrsv = Nullsv; #endif /* USE_THREADS */ + sv_free_arenas(); + /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { @@ -822,7 +836,7 @@ setuid perl scripts securely.\n"); PL_origargv = argv; PL_origargc = argc; -#ifndef VMS /* VMS doesn't have environ array */ +#if !defined( VMS) && !defined(EPOC) /* VMS doesn't have environ array */ PL_origenviron = environ; #endif @@ -1180,6 +1194,7 @@ print \" \\@INC:\\n @INC\\n\";"); validate_suid(validarg, scriptname,fdscript); +#ifndef PERL_MICRO #if defined(SIGCHLD) || defined(SIGCLD) { #ifndef SIGCHLD @@ -1194,6 +1209,7 @@ print \" \\@INC:\\n @INC\\n\";"); } } #endif +#endif #ifdef MACOS_TRADITIONAL if (PL_doextract || gMacPerl_AlwaysExtract) { @@ -1239,12 +1255,18 @@ print \" \\@INC:\\n @INC\\n\";"); if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) +#ifndef PERL_MICRO +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(EPOC) init_os_extras(); #endif +#endif #ifdef USE_SOCKS +# ifdef HAS_SOCKS5_INIT + socks5_init(argv[0]); +# else SOCKSinit(argv[0]); +# endif #endif init_predump_symbols(); @@ -1609,7 +1631,6 @@ L. I32 Perl_call_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ { dSP; @@ -1657,7 +1678,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) method_op.op_next = PL_op; method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; - PL_op = &method_op; + PL_op = (OP*)&method_op; } if (!(flags & G_EVAL)) { @@ -1667,7 +1688,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) CATCH_SET(oldcatch); } else { - cLOGOP->op_other = PL_op; + myop.op_other = (OP*)&myop; PL_markstack_ptr--; /* we're trying to emulate pp_entertry() here */ { @@ -1780,9 +1801,9 @@ S_call_body(pTHX_ OP *myop, int is_eval) if (PL_op == myop) { if (is_eval) - PL_op = Perl_pp_entereval(aTHX); + PL_op = Perl_pp_entereval(aTHX); /* this doesn't do a POPMARK */ else - PL_op = Perl_pp_entersub(aTHX); + PL_op = Perl_pp_entersub(aTHX); /* this does */ } if (PL_op) CALLRUNOPS(aTHX); @@ -1904,7 +1925,6 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) dSP; SV* sv = newSVpv(p, 0); - PUSHMARK(SP); eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -2045,9 +2065,25 @@ Perl_moreswitches(pTHX_ char *s) case 'd': forbid_setid("-d"); s++; - if (*s == ':' || *s == '=') { - my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s)); + /* The following permits -d:Mod to accepts arguments following an = + in the fashion that -MSome::Mod does. */ + if (*s == ':' || *s == '=') { + char *start; + SV *sv; + sv = newSVpv("use Devel::", 0); + start = ++s; + /* We now allow -d:Module=Foo,Bar */ + while(isALNUM(*s) || *s==':') ++s; + if (*s != '=') + sv_catpv(sv, start); + else { + sv_catpvn(sv, start, s-start); + sv_catpv(sv, " split(/,/,q{"); + sv_catpv(sv, ++s); + sv_catpv(sv, "})"); + } s += strlen(s); + my_setenv("PERL5DB", SvPV(sv, PL_na)); } if (!PL_perldb) { PL_perldb = PERLDB_ALL; @@ -2213,7 +2249,7 @@ Perl_moreswitches(pTHX_ char *s) return s; case 'v': PerlIO_printf(PerlIO_stdout(), - Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", + Perl_form(aTHX_ "\nThis is perl, v%"VDf" built for %s", PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) @@ -2226,6 +2262,10 @@ Perl_moreswitches(pTHX_ char *s) PerlIO_printf(PerlIO_stdout(), "\n\nCopyright 1987-2000, Larry Wall\n"); +#ifdef MACOS_TRADITIONAL + PerlIO_printf(PerlIO_stdout(), + "\nMacOS port Copyright (c) 1991-2000, Matthias Neeracher\n"); +#endif #ifdef MSDOS PerlIO_printf(PerlIO_stdout(), "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -2282,7 +2322,7 @@ Perl_moreswitches(pTHX_ char *s) PerlIO_printf(PerlIO_stdout(), "\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ -GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n\ +GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using `man perl' or `perldoc perl'. If you have access to the\n\ Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n"); @@ -2512,6 +2552,11 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript) } } +#ifdef USE_ITHREADS + Safefree(CopFILE(PL_curcop)); +#else + SvREFCNT_dec(CopFILEGV(PL_curcop)); +#endif CopFILE_set(PL_curcop, PL_origfilename); if (strEQ(PL_origfilename,"-")) scriptname = ""; @@ -2827,16 +2872,6 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript) if (tmpstatbuf.st_dev != PL_statbuf.st_dev || tmpstatbuf.st_ino != PL_statbuf.st_ino) { (void)PerlIO_close(PL_rsfp); - if (PL_rsfp = PerlProc_popen("/bin/mail root","w")) { /* heh, heh */ - PerlIO_printf(PL_rsfp, -"User %"Uid_t_f" tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\ -(Filename of set-id script was %s, uid %"Uid_t_f" gid %"Gid_t_f".)\n\nSincerely,\nperl\n", - PL_uid,(long)tmpstatbuf.st_dev, (long)tmpstatbuf.st_ino, - (long)PL_statbuf.st_dev, (long)PL_statbuf.st_ino, - CopFILE(PL_curcop), - PL_statbuf.st_uid, PL_statbuf.st_gid); - (void)PerlProc_pclose(PL_rsfp); - } Perl_croak(aTHX_ "Permission denied\n"); } if ( @@ -3264,7 +3299,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register } if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) #ifdef OS2 - sv_setpv(GvSV(tmpgv), os2_execname()); + sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); #else sv_setpv(GvSV(tmpgv),PL_origargv[0]); #endif @@ -3433,7 +3468,7 @@ S_init_perllib(pTHX) #endif /* MACOS_TRADITIONAL */ } -#if defined(DOSISH) +#if defined(DOSISH) || defined(EPOC) # define PERLLIB_SEP ';' #else # if defined(VMS) @@ -3655,7 +3690,14 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); - SAVEFREESV(cv); + if ((PL_minus_c & 0x10) && (paramList == PL_beginav)) { + /* save PL_beginav for compiler */ + if (! PL_beginav_save) + PL_beginav_save = newAV(); + av_push(PL_beginav_save, (SV*)cv); + } else { + SAVEFREESV(cv); + } #ifdef PERL_FLEXIBLE_EXCEPTIONS CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); #else