X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=091dd6253f492672197a008b96e95e2e9ee0fa2a;hb=c670e63af2af3c154935c36a0c6fb77f614af0bd;hp=9ef9cd71168c4ba0874ad215728612cc19cbd6f6;hpb=f89a1e08e6fb41e93df685b7f838ff9bf916f2f4;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 9ef9cd7..091dd62 100644 --- a/perl.c +++ b/perl.c @@ -1,3 +1,4 @@ +#line 2 "perl.c" /* perl.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 @@ -26,6 +27,7 @@ #define PERL_IN_PERL_C #include "perl.h" #include "patchlevel.h" /* for local_patches */ +#include "XSUB.h" #ifdef NETWARE #include "nwutil.h" @@ -106,8 +108,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 } @@ -390,6 +390,8 @@ perl_construct(pTHXx) PL_timesbase.tms_cstime = 0; #endif + PL_osname = Perl_savepvn(aTHX_ STR_WITH_LEN(OSNAME)); + PL_registered_mros = newHV(); /* Start with 1 bucket, for DFS. It's unlikely we'll need more. */ HvMAX(PL_registered_mros) = 0; @@ -536,6 +538,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; @@ -563,6 +567,7 @@ perl_destruct(pTHXx) } LEAVE; FREETMPS; + assert(PL_scopestack_ix == 0); /* Need to flush since END blocks can produce output */ my_fflush_all(); @@ -985,7 +990,6 @@ perl_destruct(pTHXx) /* clear utf8 character classes */ SvREFCNT_dec(PL_utf8_alnum); - SvREFCNT_dec(PL_utf8_alnumc); SvREFCNT_dec(PL_utf8_ascii); SvREFCNT_dec(PL_utf8_alpha); SvREFCNT_dec(PL_utf8_space); @@ -1005,7 +1009,6 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); PL_utf8_alnum = NULL; - PL_utf8_alnumc = NULL; PL_utf8_ascii = NULL; PL_utf8_alpha = NULL; PL_utf8_space = NULL; @@ -1048,21 +1051,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. */ @@ -1628,6 +1631,90 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) return ret; } +/* This needs to stay in perl.c, as perl.c is compiled with different flags for + miniperl, and we need to see those flags reflected in the values here. */ + +/* What this returns is subject to change. Use the public interface in Config. + */ +static void +S_Internals_V(pTHX_ CV *cv) +{ + dXSARGS; +#ifdef LOCAL_PATCH_COUNT + const int local_patch_count = LOCAL_PATCH_COUNT; +#else + const int local_patch_count = 0; +#endif + const int entries = 3 + local_patch_count; + int i; + static char non_bincompat_options[] = +# ifdef DEBUGGING + " DEBUGGING" +# endif +# ifdef NO_MATHOMS + " NO_MATHOMS" +# endif +# ifdef PERL_DISABLE_PMC + " PERL_DISABLE_PMC" +# endif +# ifdef PERL_DONT_CREATE_GVSV + " PERL_DONT_CREATE_GVSV" +# endif +# ifdef PERL_IS_MINIPERL + " PERL_IS_MINIPERL" +# endif +# ifdef PERL_MALLOC_WRAP + " PERL_MALLOC_WRAP" +# endif +# ifdef PERL_MEM_LOG + " PERL_MEM_LOG" +# endif +# ifdef PERL_MEM_LOG_NOIMPL + " PERL_MEM_LOG_NOIMPL" +# endif +# ifdef PERL_USE_DEVEL + " PERL_USE_DEVEL" +# endif +# ifdef PERL_USE_SAFE_PUTENV + " PERL_USE_SAFE_PUTENV" +# endif +# ifdef USE_SITECUSTOMIZE + " USE_SITECUSTOMIZE" +# endif +# ifdef USE_FAST_STDIO + " USE_FAST_STDIO" +# endif + ; + PERL_UNUSED_ARG(cv); + PERL_UNUSED_ARG(items); + + EXTEND(SP, entries); + + PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0))); + PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, + sizeof(non_bincompat_options) - 1, SVs_TEMP)); + +#ifdef __DATE__ +# ifdef __TIME__ + PUSHs(Perl_newSVpvn_flags(aTHX_ + STR_WITH_LEN("Compiled at " __DATE__ " " __TIME__), + SVs_TEMP)); +# else + PUSHs(Perl_newSVpvn_flags(aTHX_ STR_WITH_LEN("Compiled on " __DATE__), + SVs_TEMP)); +# endif +#else + PUSHs(&PL_sv_undef); +#endif + + for (i = 1; i <= local_patch_count; i++) { + /* This will be an undef, if PL_localpatches[i] is NULL. */ + PUSHs(sv_2mortal(newSVpv(PL_localpatches[i], 0))); + } + + XSRETURN(entries); +} + #define INCPUSH_UNSHIFT 0x01 #define INCPUSH_ADD_OLD_VERS 0x02 #define INCPUSH_ADD_VERSIONED_SUB_DIRS 0x04 @@ -1759,97 +1846,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { SV *opts_prog; - Perl_av_create_and_push(aTHX_ &PL_preambleav, newSVpvs("use Config;")); if (*++s != ':') { - /* Can't do newSVpvs() as that would involve pre-processor - condititionals inside a macro expansion. */ - opts_prog = Perl_newSVpv(aTHX_ "$_ = join ' ', sort qw(" -# ifdef DEBUGGING - " DEBUGGING" -# endif -# ifdef NO_MATHOMS - " NO_MATHOMS" -# endif -# ifdef PERL_DISABLE_PMC - " PERL_DISABLE_PMC" -# endif -# ifdef PERL_DONT_CREATE_GVSV - " PERL_DONT_CREATE_GVSV" -# endif -# ifdef PERL_MALLOC_WRAP - " PERL_MALLOC_WRAP" -# endif -# ifdef PERL_MEM_LOG - " PERL_MEM_LOG" -# endif -# ifdef PERL_MEM_LOG_NOIMPL - " PERL_MEM_LOG_NOIMPL" -# endif -# ifdef PERL_USE_DEVEL - " PERL_USE_DEVEL" -# endif -# ifdef PERL_USE_SAFE_PUTENV - " PERL_USE_SAFE_PUTENV" -# endif -# ifdef USE_SITECUSTOMIZE - " USE_SITECUSTOMIZE" -# endif -# ifdef USE_FAST_STDIO - " USE_FAST_STDIO" -# endif - , 0); - - sv_catpv(opts_prog, PL_bincompat_options); - /* Terminate the qw(, and then wrap at 76 columns. */ - sv_catpvs(opts_prog, "); s/(?=.{53})(.{1,53}) /$1\\n /mg;print Config::myconfig(),"); -#ifdef VMS - sv_catpvs(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n"); -#else - sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n"); -#endif - sv_catpvs(opts_prog," Compile-time options: $_\\n\","); - -#if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) { - int i; - sv_catpvs(opts_prog, - "\" Locally applied patches:\\n\","); - for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { - if (PL_localpatches[i]) - Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,", - 0, PL_localpatches[i], 0); - } - } -#endif - Perl_sv_catpvf(aTHX_ opts_prog, - "\" Built under %s\\n",OSNAME); -#ifdef __DATE__ -# ifdef __TIME__ - sv_catpvs(opts_prog, - " Compiled at " __DATE__ " " __TIME__ "\\n\""); -# else - sv_catpvs(opts_prog, " Compiled on " __DATE__ "\\n\""); -# endif -#endif - sv_catpvs(opts_prog, "; $\"=\"\\n \"; " - "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } " - "sort grep {/^PERL/} keys %ENV; "); -#ifdef __CYGWIN__ - sv_catpvs(opts_prog, - "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); -#endif - sv_catpvs(opts_prog, - "print \" \\%ENV:\\n @env\\n\" if @env;" - "print \" \\@INC:\\n @INC\\n\";"); + opts_prog = newSVpvs("use Config; Config::_V()"); } else { ++s; opts_prog = Perl_newSVpvf(aTHX_ - "Config::config_vars(qw%c%s%c)", + "use Config; Config::config_vars(qw%c%s%c)", 0, s, 0); s += strlen(s); } - av_push(PL_preambleav, opts_prog); + Perl_av_create_and_push(aTHX_ &PL_preambleav, opts_prog); /* don't look for script or read stdin */ scriptname = BIT_BUCKET; goto reswitch; @@ -1942,10 +1949,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } -#ifdef USE_SITECUSTOMIZE +#if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL) if (!minus_f) { + /* SITELIB_EXP is a function call on Win32. + The games with local $! are to avoid setting errno if there is no + sitecustomize script. */ + const char *const sitelib = SITELIB_EXP; (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ "BEGIN { do '%s/sitecustomize.pl' }", SITELIB_EXP)); + Perl_newSVpvf(aTHX_ + "BEGIN { do {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib)); } #endif @@ -1986,9 +1998,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); } } @@ -2018,6 +2029,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) boot_core_PerlIO(); boot_core_UNIVERSAL(); boot_core_mro(); + newXS("Internals::V", S_Internals_V, __FILE__); if (xsinit) (*xsinit)(aTHX); /* in case linked C routines want magical variables */ @@ -2049,6 +2061,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #if defined(__SYMBIAN32__) PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */ #endif +# ifndef PERL_IS_MINIPERL if (PL_unicode) { /* Requires init_predump_symbols(). */ if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { @@ -2087,6 +2100,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } } +#endif { const char *s; @@ -2253,8 +2267,9 @@ S_run_body(pTHX_ I32 oldscope) exit(0); /* less likely to core dump than my_exit(0) */ } #endif - DEBUG_x(dump_all()); #ifdef DEBUGGING + if (DEBUG_x_TEST || DEBUG_B_TEST) + dump_all_perl(!DEBUG_B_TEST); if (!DEBUG_q_TEST) PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); #endif @@ -2484,9 +2499,13 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { + STRLEN len; PERL_ARGS_ASSERT_CALL_METHOD; - return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); + len = strlen(methname); + + /* XXX: sv_2mortal(newSVpvn_share(methname, len)) can be faster */ + return call_sv(newSVpvn_flags(methname, len, SVs_TEMP), flags | G_METHOD); } /* May be called with any of a CV, a GV, or an SV containing the name. */ @@ -2589,8 +2608,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: @@ -2691,8 +2708,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: @@ -2863,6 +2878,8 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " C Copy On Write", " A Consistency checks on internal structures", " q quiet - currently only suppresses the 'EXECUTING' message", + " M trace smart match resolution", + " B dump suBroutine definitions, including special Blocks like BEGIN", NULL }; int i = 0; @@ -2871,7 +2888,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; for (; isALNUM(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3203,10 +3220,11 @@ Perl_moreswitches(pTHX_ const char *s) } #endif PerlIO_printf(PerlIO_stdout(), - "\nThis is perl, %"SVf - " built for %s", - level, - ARCHNAME); + "\nThis is perl " STRINGIFY(PERL_REVISION) + ", version " STRINGIFY(PERL_VERSION) + ", subversion " STRINGIFY(PERL_SUBVERSION) + " (%"SVf") built for " ARCHNAME, level + ); SvREFCNT_dec(level); } #else /* DGUX */ @@ -3795,6 +3813,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); @@ -3821,6 +3842,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); } @@ -3864,9 +3888,6 @@ S_init_predump_symbols(pTHX) GvIOp(tmpgv) = MUTABLE_IO(SvREFCNT_inc_simple(io)); PL_statname = newSV(0); /* last filename we did stat on */ - - Safefree(PL_osname); - PL_osname = savepv(OSNAME); } void @@ -4004,7 +4025,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 @@ -4045,6 +4066,10 @@ S_init_perllib(pTHX) #endif /* VMS */ } +#ifndef PERL_IS_MINIPERL + /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC + (and not the architecture specific directories from $ENV{PERL5LIB}) */ + /* Use the ~-expanded versions of APPLLIB (undocumented), ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB */ @@ -4175,6 +4200,7 @@ S_init_perllib(pTHX) INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS |INCPUSH_CAN_RELOCATE); #endif +#endif /* !PERL_IS_MINIPERL */ if (!PL_tainting) S_incpush(aTHX_ STR_WITH_LEN("."), 0); @@ -4561,16 +4587,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: