X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9f28b43c85ae4811b0768bb37378b21550f27c7d..9eafb59736e2d046fbc9fd6762a4ebe03b15288b:/perl.c?ds=sidebyside diff --git a/perl.c b/perl.c index 2c51286..dfb549d 100644 --- a/perl.c +++ b/perl.c @@ -1,7 +1,9 @@ +#line 2 "perl.c" /* perl.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 - * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall and others + * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 by Larry Wall + * and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -107,8 +109,6 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) OP_REFCNT_INIT; HINTS_REFCNT_INIT; MUTEX_INIT(&PL_dollarzero_mutex); -# endif -#ifdef PERL_IMPLICIT_CONTEXT MUTEX_INIT(&PL_my_ctx_mutex); # endif } @@ -539,6 +539,8 @@ perl_destruct(pTHXx) PERL_UNUSED_ARG(my_perl); #endif + assert(PL_scopestack_ix == 1); + /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -566,6 +568,7 @@ perl_destruct(pTHXx) } LEAVE; FREETMPS; + assert(PL_scopestack_ix == 0); /* Need to flush since END blocks can produce output */ my_fflush_all(); @@ -1049,21 +1052,21 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_isarev); FREETMPS; - if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { + if (destruct_level >= 2) { if (PL_scopestack_ix != 0) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", - (long)PL_scopestack_ix); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced saves: %ld more saves than restores\n", - (long)PL_savestack_ix); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced saves: %ld more saves than restores\n", + (long)PL_savestack_ix); if (PL_tmps_floor != -1) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", - (long)PL_tmps_floor + 1); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced tmps: %ld more allocs than frees\n", + (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", - (long)cxstack_ix + 1); + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", + (long)cxstack_ix + 1); } /* Now absolutely destruct everything, somehow or other, loops or no. */ @@ -1160,7 +1163,7 @@ perl_destruct(pTHXx) PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" " flags=0x%"UVxf " refcnt=%"UVuf pTHX__FORMAT "\n" - "\tallocated at %s:%d %s %s%s\n", + "\tallocated at %s:%d %s %s%s; serial %"UVuf"\n", (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", @@ -1168,7 +1171,8 @@ perl_destruct(pTHXx) sv->sv_debug_inpad ? "for" : "by", sv->sv_debug_optype ? PL_op_name[sv->sv_debug_optype]: "(none)", - sv->sv_debug_cloned ? " (cloned)" : "" + sv->sv_debug_cloned ? " (cloned)" : "", + sv->sv_debug_serial ); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP Perl_dump_sv_child(aTHX_ sv); @@ -1650,7 +1654,7 @@ S_Internals_V(pTHX_ CV *cv) " DEBUGGING" # endif # ifdef NO_MATHOMS - " NO_MATHOMS" + " NO_MATHOMS" # endif # ifdef PERL_DISABLE_PMC " PERL_DISABLE_PMC" @@ -1676,12 +1680,18 @@ S_Internals_V(pTHX_ CV *cv) # ifdef PERL_USE_SAFE_PUTENV " PERL_USE_SAFE_PUTENV" # endif -# ifdef USE_SITECUSTOMIZE - " USE_SITECUSTOMIZE" -# endif +# ifdef USE_ATTRIBUTES_FOR_PERLIO + " USE_ATTRIBUTES_FOR_PERLIO" +# endif # ifdef USE_FAST_STDIO " USE_FAST_STDIO" # endif +# ifdef USE_PERL_ATOF + " USE_PERL_ATOF" +# endif +# ifdef USE_SITECUSTOMIZE + " USE_SITECUSTOMIZE" +# endif ; PERL_UNUSED_ARG(cv); PERL_UNUSED_ARG(items); @@ -1996,9 +2006,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # endif Sighandler_t sigstate = rsignal_state(SIGCHLD); if (sigstate == (Sighandler_t) SIG_IGN) { - if (ckWARN(WARN_SIGNAL)) - Perl_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); } } @@ -2607,8 +2616,6 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) - Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: @@ -2709,8 +2716,6 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PL_curstash = PL_defstash; FREETMPS; JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) - Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); /* NOTREACHED */ case 3: @@ -3223,9 +3228,11 @@ Perl_moreswitches(pTHX_ const char *s) } #endif PerlIO_printf(PerlIO_stdout(), - "\nThis is perl, %"SVf - " built for " ARCHNAME, - level); + "\nThis is perl " STRINGIFY(PERL_REVISION) + ", version " STRINGIFY(PERL_VERSION) + ", subversion " STRINGIFY(PERL_SUBVERSION) + " (%"SVf") built for " ARCHNAME, level + ); SvREFCNT_dec(level); } #else /* DGUX */ @@ -3250,7 +3257,7 @@ Perl_moreswitches(pTHX_ const char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2009, Larry Wall\n"); + "\n\nCopyright 1987-2010, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PerlIO_stdout(), "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3814,6 +3821,9 @@ Perl_init_stacks(pTHX) SET_MARK_OFFSET; Newx(PL_scopestack,REASONABLE(32),I32); +#ifdef DEBUGGING + Newx(PL_scopestack_name,REASONABLE(32),const char*); +#endif PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); @@ -3840,6 +3850,9 @@ S_nuke_stacks(pTHX) Safefree(PL_tmps_stack); Safefree(PL_markstack); Safefree(PL_scopestack); +#ifdef DEBUGGING + Safefree(PL_scopestack_name); +#endif Safefree(PL_savestack); } @@ -3850,10 +3863,34 @@ S_init_predump_symbols(pTHX) dVAR; GV *tmpgv; IO *io; + AV *isa; sv_setpvs(get_sv("\"", GV_ADD), " "); PL_ofsgv = (GV*)SvREFCNT_inc(gv_fetchpvs(",", GV_ADD|GV_NOTQUAL, SVt_PV)); + + /* Historically, PVIOs were blessed into IO::Handle, unless + FileHandle was loaded, in which case they were blessed into + that. Action at a distance. + However, if we simply bless into IO::Handle, we break code + that assumes that PVIOs will have (among others) a seek + method. IO::File inherits from IO::Handle and IO::Seekable, + and provides the needed methods. But if we simply bless into + it, then we break code that assumed that by loading + IO::Handle, *it* would work. + So a compromise is to set up the correct @IO::File::ISA, + so that code that does C; will still work. + */ + + isa = get_av("IO::File::ISA", GV_ADD | GV_ADDMULTI); + av_push(isa, newSVpvs("IO::Handle")); + av_push(isa, newSVpvs("IO::Seekable")); + av_push(isa, newSVpvs("Exporter")); + (void) gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVGV); + (void) gv_fetchpvs("IO::Seekable::", GV_ADD, SVt_PVGV); + (void) gv_fetchpvs("Exporter::", GV_ADD, SVt_PVGV); + + PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stdingv); io = GvIOp(PL_stdingv); @@ -4020,7 +4057,7 @@ S_init_perllib(pTHX) const char *perl5lib = NULL; #endif const char *s; -#ifdef WIN32 +#if defined(WIN32) && !defined(PERL_IS_MINIPERL) STRLEN len; #endif @@ -4066,7 +4103,7 @@ S_init_perllib(pTHX) (and not the architecture specific directories from $ENV{PERL5LIB}) */ /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB + SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB */ #ifdef APPLLIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), @@ -4170,7 +4207,7 @@ S_init_perllib(pTHX) } /* Use the ~-expanded versions of APPLLIB (undocumented), - ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB + SITELIB and VENDORLIB for older versions */ #ifdef APPLLIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS @@ -4582,16 +4619,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); JMPENV_POP; - if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { - if (paramList == PL_beginav) - Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); - else - Perl_croak(aTHX_ "%s failed--call queue aborted", - paramList == PL_checkav ? "CHECK" - : paramList == PL_initav ? "INIT" - : paramList == PL_unitcheckav ? "UNITCHECK" - : "END"); - } my_exit_jump(); /* NOTREACHED */ case 3: