X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/d7c0d2821cad1d2e5b6b3d6440e7c22bfaae9559..d1eb31775715b0fcd7f36308da961c0698205d9f:/perl.c diff --git a/perl.c b/perl.c index 6c1b543..1ca8bc8 100644 --- a/perl.c +++ b/perl.c @@ -26,6 +26,7 @@ #define PERL_IN_PERL_C #include "perl.h" #include "patchlevel.h" /* for local_patches */ +#include "XSUB.h" #ifdef NETWARE #include "nwutil.h" @@ -390,6 +391,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; @@ -985,7 +988,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 +1007,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 +1049,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 +1629,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 +1844,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 +1947,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 +1996,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 +2027,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 +2059,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 +2098,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } } +#endif { const char *s; @@ -2253,8 +2265,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 +2497,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. */ @@ -2864,6 +2881,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " 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; @@ -2872,7 +2890,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[] = "psltocPmfrxuUHXDSTRJvCAqM"; + static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMB"; for (; isALNUM(**s); (*s)++) { const char * const d = strchr(debopts,**s); @@ -3205,9 +3223,8 @@ Perl_moreswitches(pTHX_ const char *s) #endif PerlIO_printf(PerlIO_stdout(), "\nThis is perl, %"SVf - " built for %s", - level, - ARCHNAME); + " built for " ARCHNAME, + level); SvREFCNT_dec(level); } #else /* DGUX */ @@ -3865,9 +3882,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 @@ -4046,6 +4060,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 */ @@ -4176,6 +4194,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);