X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f0e3f042f14b829ffcf1b636f3090c8f69fa2a97..1755228446177f0026aa201ff2cc37653bca01a3:/perl.c diff --git a/perl.c b/perl.c index 126de99..45bc4ae 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, 2011 + * 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. @@ -11,7 +13,7 @@ /* * A ship then new they built for him * of mithril and of elven-glass - * --from Bilbo's song of Eärendil + * --from Bilbo's song of Eärendil * * [p.236 of _The Lord of the Rings_, II/i: "Many Meetings"] */ @@ -22,10 +24,15 @@ * function of the interpreter; that can be found in perlmain.c */ +#ifdef PERL_IS_MINIPERL +# define USE_SITECUSTOMIZE +#endif + #include "EXTERN.h" #define PERL_IN_PERL_C #include "perl.h" #include "patchlevel.h" /* for local_patches */ +#include "XSUB.h" #ifdef NETWARE #include "nwutil.h" @@ -77,12 +84,6 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); # define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp) #endif -#define CALL_BODY_EVAL(myop) \ - if (PL_op == (myop)) \ - PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); \ - if (PL_op) \ - CALLRUNOPS(aTHX); - #define CALL_BODY_SUB(myop) \ if (PL_op == (myop)) \ PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ @@ -106,8 +107,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 } @@ -347,6 +346,7 @@ perl_construct(pTHXx) PL_stashcache = newHV(); PL_patchlevel = newSVpvs("v" PERL_VERSION_STRING); + PL_apiversion = newSVpvs("v" PERL_API_VERSION_STRING); #ifdef HAS_MMAP if (!PL_mmap_page_size) { @@ -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; @@ -557,17 +561,20 @@ perl_destruct(pTHXx) JMPENV_PUSH(x); PERL_UNUSED_VAR(x); - if (PL_endav && !PL_minus_c) + if (PL_endav && !PL_minus_c) { + PERL_SET_PHASE(PERL_PHASE_END); call_list(PL_scopestack_ix, PL_endav); + } JMPENV_POP; } LEAVE; FREETMPS; + assert(PL_scopestack_ix == 0); /* Need to flush since END blocks can produce output */ my_fflush_all(); - if (CALL_FPTR(PL_threadhook)(aTHX)) { + if (PL_threadhook(aTHX)) { /* Threads hook has vetoed further cleanup */ PL_veto_cleanup = TRUE; return STATUS_EXIT; @@ -744,9 +751,13 @@ perl_destruct(pTHXx) PL_main_root = NULL; } PL_main_start = NULL; + /* note that PL_main_cv isn't usually actually freed at this point, + * due to the CvOUTSIDE refs from subs compiled within it. It will + * get freed once all the subs are freed in sv_clean_all(), for + * destruct_level > 0 */ SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; - PL_dirty = TRUE; + PERL_SET_PHASE(PERL_PHASE_DESTRUCT); /* Tell PerlIO we are about to tear things apart in case we have layers which are using resources that should @@ -763,8 +774,6 @@ perl_destruct(pTHXx) */ sv_clean_objs(); PL_sv_objcount = 0; - if (PL_defoutgv && !SvREFCNT(PL_defoutgv)) - PL_defoutgv = NULL; /* may have been freed */ } /* unhook hooks which will soon be, or use, destroyed data */ @@ -826,9 +835,6 @@ perl_destruct(pTHXx) return STATUS_EXIT; } - /* reset so print() ends up where we expect */ - setdefout(NULL); - #ifdef USE_ITHREADS /* the syntax tree is shared between clones * so op_free(PL_main_root) only ReREFCNT_dec's @@ -864,13 +870,13 @@ perl_destruct(pTHXx) PL_minus_F = FALSE; PL_doswitches = FALSE; PL_dowarn = G_WARN_OFF; - PL_doextract = FALSE; PL_sawampersand = FALSE; /* must save all match strings */ PL_unsafe = FALSE; Safefree(PL_inplace); PL_inplace = NULL; SvREFCNT_dec(PL_patchlevel); + SvREFCNT_dec(PL_apiversion); if (PL_e_script) { SvREFCNT_dec(PL_e_script); @@ -899,14 +905,6 @@ perl_destruct(pTHXx) /* defgv, aka *_ should be taken care of elsewhere */ - /* clean up after study() */ - SvREFCNT_dec(PL_lastscream); - PL_lastscream = NULL; - Safefree(PL_screamfirst); - PL_screamfirst = 0; - Safefree(PL_screamnext); - PL_screamnext = 0; - /* float buffer */ Safefree(PL_efloatbuf); PL_efloatbuf = NULL; @@ -985,7 +983,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); @@ -1004,8 +1001,8 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_utf8_tofold); SvREFCNT_dec(PL_utf8_idstart); SvREFCNT_dec(PL_utf8_idcont); + SvREFCNT_dec(PL_utf8_foldclosures); PL_utf8_alnum = NULL; - PL_utf8_alnumc = NULL; PL_utf8_ascii = NULL; PL_utf8_alpha = NULL; PL_utf8_space = NULL; @@ -1024,18 +1021,21 @@ perl_destruct(pTHXx) PL_utf8_tofold = NULL; PL_utf8_idstart = NULL; PL_utf8_idcont = NULL; + PL_utf8_foldclosures = NULL; if (!specialWARN(PL_compiling.cop_warnings)) PerlMemShared_free(PL_compiling.cop_warnings); PL_compiling.cop_warnings = NULL; - Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash); - PL_compiling.cop_hints_hash = NULL; + cophh_free(CopHINTHASH_get(&PL_compiling)); + CopHINTHASH_set(&PL_compiling, cophh_new_empty()); CopFILE_free(&PL_compiling); CopSTASH_free(&PL_compiling); /* Prepare to destruct main symbol table. */ hv = PL_defstash; + /* break ref loop *:: <=> %:: */ + (void)hv_delete(hv, "main::", 6, G_DISCARD); PL_defstash = 0; SvREFCNT_dec(hv); SvREFCNT_dec(PL_curstname); @@ -1048,23 +1048,29 @@ 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); } +#ifdef PERL_IMPLICIT_CONTEXT + /* the entries in this list are allocated via SV PVX's, so get freed + * in sv_clean_all */ + Safefree(PL_my_cxt_list); +#endif + /* Now absolutely destruct everything, somehow or other, loops or no. */ /* the 2 is for PL_fdpid and PL_strtab */ @@ -1111,7 +1117,6 @@ perl_destruct(pTHXx) Safefree(array); HvARRAY(PL_strtab) = 0; HvTOTALKEYS(PL_strtab) = 0; - HvFILL(PL_strtab) = 0; } SvREFCNT_dec(PL_strtab); @@ -1155,11 +1160,12 @@ perl_destruct(pTHXx) for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != SVTYPEMASK) { + if (SvTYPE(sv) != (svtype)SVTYPEMASK) { 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 (parent 0x%"UVxf");" + "serial %"UVuf"\n", (void*)sv, (UV)sv->sv_flags, (UV)sv->sv_refcnt pTHX__VALUE, sv->sv_debug_file ? sv->sv_debug_file : "(unknown)", @@ -1167,7 +1173,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)" : "" + PTR2UV(sv->sv_debug_parent), + sv->sv_debug_serial ); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP Perl_dump_sv_child(aTHX_ sv); @@ -1231,8 +1238,6 @@ perl_destruct(pTHXx) Safefree(PL_psig_name); PL_psig_name = (SV**)NULL; PL_psig_ptr = (SV**)NULL; - Safefree(PL_psig_pend); - PL_psig_pend = (int*)NULL; { /* We need to NULL PL_psig_pend first, so that signal handlers know not to use it */ @@ -1460,7 +1465,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) /* [perl #22371] Algorimic Complexity Attack on Perl 5.6.1, 5.8.0 * This MUST be done before any hash stores or fetches take place. - * If you set PL_rehash_seed (and assumedly also PL_rehash_seed_set) + * If you set PL_rehash_seed (and presumably also PL_rehash_seed_set) * yourself, it is your responsibility to provide a good random seed! * You can also define PERL_HASH_SEED in compile time, see hv.h. */ if (!PL_rehash_seed_set) @@ -1598,10 +1603,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) switch (ret) { case 0: parse_body(env,xsinit); - if (PL_unitcheckav) + if (PL_unitcheckav) { call_list(oldscope, PL_unitcheckav); - if (PL_checkav) + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); call_list(oldscope, PL_checkav); + } ret = 0; break; case 1: @@ -1613,10 +1621,13 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) LEAVE; FREETMPS; PL_curstash = PL_defstash; - if (PL_unitcheckav) + if (PL_unitcheckav) { call_list(oldscope, PL_unitcheckav); - if (PL_checkav) + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); call_list(oldscope, PL_checkav); + } ret = STATUS_EXIT; break; case 3: @@ -1628,6 +1639,114 @@ 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 HOMEGROWN_POSIX_SIGNALS + " HOMEGROWN_POSIX_SIGNALS" +# 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_EXTERNAL_GLOB + " PERL_EXTERNAL_GLOB" +# 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_PRESERVE_IVUV + " PERL_PRESERVE_IVUV" +# endif +# ifdef PERL_USE_DEVEL + " PERL_USE_DEVEL" +# endif +# ifdef PERL_USE_SAFE_PUTENV + " PERL_USE_SAFE_PUTENV" +# endif +# ifdef UNLINK_ALL_VERSIONS + " UNLINK_ALL_VERSIONS" +# endif +# ifdef USE_ATTRIBUTES_FOR_PERLIO + " USE_ATTRIBUTES_FOR_PERLIO" +# endif +# ifdef USE_FAST_STDIO + " USE_FAST_STDIO" +# endif +# ifdef USE_LOCALE + " USE_LOCALE" +# endif +# ifdef USE_LOCALE_CTYPE + " USE_LOCALE_CTYPE" +# endif +# ifdef USE_PERL_ATOF + " USE_PERL_ATOF" +# endif +# ifdef USE_SITECUSTOMIZE + " USE_SITECUSTOMIZE" +# 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 @@ -1647,6 +1766,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) const char *scriptname = NULL; VOL bool dosearch = FALSE; register char c; + bool doextract = FALSE; const char *cddir = NULL; #ifdef USE_SITECUSTOMIZE bool minus_f = FALSE; @@ -1654,6 +1774,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) SV *linestr_sv = newSV_type(SVt_PVIV); bool add_read_e_script = FALSE; + PERL_SET_PHASE(PERL_PHASE_START); + SvGROW(linestr_sv, 80); sv_setpvs(linestr_sv,""); @@ -1759,103 +1881,23 @@ 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; } case 'x': - PL_doextract = TRUE; + doextract = TRUE; s++; if (*s) cddir = s; @@ -1942,10 +1984,26 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } -#ifdef USE_SITECUSTOMIZE +#if defined(USE_SITECUSTOMIZE) if (!minus_f) { + /* The games with local $! are to avoid setting errno if there is no + sitecustomize script. */ +# ifdef PERL_IS_MINIPERL + AV *const inc = GvAV(PL_incgv); + SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; + + if (inc0) { + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ + "BEGIN { do {local $!; -f '%"SVf"/buildcustomize.pl'} && do '%"SVf"/buildcustomize.pl' }", *inc0, *inc0)); + } +# else + /* SITELIB_EXP is a function call on Win32. */ + 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 } #endif @@ -1986,16 +2044,15 @@ 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); } } # endif #endif - if (PL_doextract) { + if (doextract) { /* This will croak if suidscript is true, as -x cannot be used with setuid scripts. */ @@ -2018,6 +2075,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 +2107,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 +2146,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } } +#endif { const char *s; @@ -2126,7 +2186,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } #endif - lex_start(linestr_sv, rsfp, TRUE); + lex_start(linestr_sv, rsfp, 0); PL_subname = newSVpvs("main"); if (add_read_e_script) @@ -2135,7 +2195,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* now parse the script */ SETERRNO(0,SS_NORMAL); - if (yyparse() || PL_parser->error_count) { + if (yyparse(GRAMPROG) || PL_parser->error_count) { if (PL_minus_c) Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename); else { @@ -2171,6 +2231,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif ENTER; + PL_restartjmpenv = NULL; PL_restartop = 0; return NULL; } @@ -2216,8 +2277,10 @@ perl_run(pTHXx) FREETMPS; PL_curstash = PL_defstash; if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && - PL_endav && !PL_minus_c) + PL_endav && !PL_minus_c) { + PERL_SET_PHASE(PERL_PHASE_END); call_list(oldscope, PL_endav); + } #ifdef MYMALLOC if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); @@ -2266,8 +2329,10 @@ S_run_body(pTHX_ I32 oldscope) } if (PERLDB_SINGLE && PL_DBsingle) sv_setiv(PL_DBsingle, 1); - if (PL_initav) + if (PL_initav) { + PERL_SET_PHASE(PERL_PHASE_INIT); call_list(oldscope, PL_initav); + } #ifdef PERL_DEBUG_READONLY_OPS Perl_pending_Slabs_to_ro(aTHX); #endif @@ -2275,7 +2340,10 @@ S_run_body(pTHX_ I32 oldscope) /* do it */ + PERL_SET_PHASE(PERL_PHASE_RUN); + if (PL_restartop) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; CALLRUNOPS(aTHX); @@ -2320,11 +2388,14 @@ Perl_get_sv(pTHX_ const char *name, I32 flags) =for apidoc p||get_av -Returns the AV of the specified Perl array. C are passed to -C. If C is set and the +Returns the AV of the specified Perl global or package array with the given +name (so it won't work on lexical variables). C are passed +to C. If C is set and the Perl variable does not exist then it will be created. If C is zero and the variable does not exist then NULL is returned. +Perl equivalent: C<@{"$name"}>. + =cut */ @@ -2426,7 +2497,10 @@ Perl_get_cv(pTHX_ const char *name, I32 flags) =for apidoc p||call_argv -Performs a callback to the specified Perl sub. See L. +Performs a callback to the specified named and package-scoped Perl subroutine +with C (a NULL-terminated array of strings) as arguments. See L. + +Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. =cut */ @@ -2485,9 +2559,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. */ @@ -2590,12 +2668,11 @@ 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: if (PL_restartop) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; goto redo_body; @@ -2630,7 +2707,8 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) /* =for apidoc p||eval_sv -Tells Perl to C the string in the SV. +Tells Perl to C the string in the SV. It supports the same flags +as C, with the obvious exception of G_EVAL. See L. =cut */ @@ -2678,7 +2756,12 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) switch (ret) { case 0: redo_body: - CALL_BODY_EVAL((OP*)&myop); + if (PL_op == (OP*)(&myop)) { + PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); + if (!PL_op) + goto fail; /* failed in compilation */ + } + CALLRUNOPS(aTHX); retval = PL_stack_sp - (PL_stack_base + oldmark); if (!(flags & G_KEEPERR)) { CLEAR_ERRSV(); @@ -2692,16 +2775,16 @@ 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: if (PL_restartop) { + PL_restartjmpenv = NULL; PL_op = PL_restartop; PL_restartop = 0; goto redo_body; } + fail: PL_stack_sp = PL_stack_base + oldmark; if ((flags & G_WANT) == G_ARRAY) retval = 0; @@ -2790,47 +2873,51 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ /* This message really ought to be max 23 lines. * Removed -h because the user already knows that option. Others? */ + /* Grouped as 6 lines per C string literal, to keep under the ANSI C 89 + minimum of 509 character string literals. */ static const char * const usage_msg[] = { -"-0[octal] specify record separator (\\0, if no argument)", -"-a autosplit mode with -n or -p (splits $_ into @F)", -"-C[number/list] enables the listed Unicode features", -"-c check syntax only (runs BEGIN and CHECK blocks)", -"-d[:debugger] run program under debugger", -"-D[number/list] set debugging flags (argument is a bit mask or alphabets)", -"-e program one line of program (several -e's allowed, omit programfile)", -"-E program like -e, but enables all optional features", -"-f don't do $sitelib/sitecustomize.pl at startup", -"-F/pattern/ split() pattern for -a switch (//'s are optional)", -"-i[extension] edit <> files in place (makes backup if extension supplied)", -"-Idirectory specify @INC/#include directory (several -I's allowed)", -"-l[octal] enable line ending processing, specifies line terminator", -"-[mM][-]module execute \"use/no module...\" before executing program", -"-n assume \"while (<>) { ... }\" loop around program", -"-p assume loop like -n but print line also, like sed", -"-s enable rudimentary parsing for switches after programfile", -"-S look for programfile using PATH environment variable", -"-t enable tainting warnings", -"-T enable tainting checks", -"-u dump core after parsing program", -"-U allow unsafe operations", -"-v print version, subversion (includes VERY IMPORTANT perl info)", -"-V[:variable] print configuration summary (or a single Config.pm variable)", -"-w enable many useful warnings (RECOMMENDED)", -"-W enable all warnings", -"-x[directory] strip off text before #!perl line and perhaps cd to directory", -"-X disable all warnings", -"\n", +" -0[octal] specify record separator (\\0, if no argument)\n" +" -a autosplit mode with -n or -p (splits $_ into @F)\n" +" -C[number/list] enables the listed Unicode features\n" +" -c check syntax only (runs BEGIN and CHECK blocks)\n" +" -d[:debugger] run program under debugger\n" +" -D[number/list] set debugging flags (argument is a bit mask or alphabets)\n", +" -e program one line of program (several -e's allowed, omit programfile)\n" +" -E program like -e, but enables all optional features\n" +" -f don't do $sitelib/sitecustomize.pl at startup\n" +" -F/pattern/ split() pattern for -a switch (//'s are optional)\n" +" -i[extension] edit <> files in place (makes backup if extension supplied)\n" +" -Idirectory specify @INC/#include directory (several -I's allowed)\n", +" -l[octal] enable line ending processing, specifies line terminator\n" +" -[mM][-]module execute \"use/no module...\" before executing program\n" +" -n assume \"while (<>) { ... }\" loop around program\n" +" -p assume loop like -n but print line also, like sed\n" +" -s enable rudimentary parsing for switches after programfile\n" +" -S look for programfile using PATH environment variable\n", +" -t enable tainting warnings\n" +" -T enable tainting checks\n" +" -u dump core after parsing program\n" +" -U allow unsafe operations\n" +" -v print version, patchlevel and license\n" +" -V[:variable] print configuration summary (or a single Config.pm variable)\n", +" -w enable many useful warnings\n" +" -W enable all warnings\n" +" -x[directory] ignore text before #!perl line (optionally cd to directory)\n" +" -X disable all warnings\n" +" \n" +"Run 'perldoc perl' for more help with Perl.\n\n", NULL }; const char * const *p = usage_msg; + PerlIO *out = PerlIO_stdout(); PERL_ARGS_ASSERT_USAGE; - PerlIO_printf(PerlIO_stdout(), - "\nUsage: %s [switches] [--] [programfile] [arguments]", + PerlIO_printf(out, + "\nUsage: %s [switches] [--] [programfile] [arguments]\n", name); while (*p) - PerlIO_printf(PerlIO_stdout(), "\n %s", *p++); + PerlIO_puts(out, *p++); } /* convert a string of -D options (or digits) into an int. @@ -2841,31 +2928,31 @@ int Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) { static const char * const usage_msgd[] = { - " Debugging flag values: (see also -d)", - " p Tokenizing and parsing (with v, displays parse stack)", - " s Stack snapshots (with v, displays all stacks)", - " l Context (loop) stack processing", - " t Trace execution", - " o Method and overloading resolution", - " c String/numeric conversions", - " P Print profiling info, source file input state", - " m Memory and SV allocation", - " f Format processing", - " r Regular expression parsing and execution", - " x Syntax tree dump", - " u Tainting checks", - " H Hash dump -- usurps values()", - " X Scratchpad allocation", - " D Cleaning up", - " T Tokenising", - " R Include reference counts of dumped variables (eg when using -Ds)", - " J Do not s,t,P-debug (Jump over) opcodes within package DB", - " v Verbose: use in conjunction with other flags", - " 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", + " Debugging flag values: (see also -d)\n" + " p Tokenizing and parsing (with v, displays parse stack)\n" + " s Stack snapshots (with v, displays all stacks)\n" + " l Context (loop) stack processing\n" + " t Trace execution\n" + " o Method and overloading resolution\n", + " c String/numeric conversions\n" + " P Print profiling info, source file input state\n" + " m Memory and SV allocation\n" + " f Format processing\n" + " r Regular expression parsing and execution\n" + " x Syntax tree dump\n", + " u Tainting checks\n" + " H Hash dump -- usurps values()\n" + " X Scratchpad allocation\n" + " D Cleaning up\n" + " T Tokenising\n" + " R Include reference counts of dumped variables (eg when using -Ds)\n", + " J Do not s,t,P-debug (Jump over) opcodes within package DB\n" + " v Verbose: use in conjunction with other flags\n" + " C Copy On Write\n" + " A Consistency checks on internal structures\n" + " q quiet - currently only suppresses the 'EXECUTING' message\n" + " M trace smart match resolution\n" + " B dump suBroutine definitions, including special Blocks like BEGIN\n", NULL }; int i = 0; @@ -2891,7 +2978,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) } else if (givehelp) { const char *const *p = usage_msgd; - while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++); + while (*p) PerlIO_puts(PerlIO_stdout(), *p++); } # ifdef EBCDIC if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING)) @@ -2989,11 +3076,21 @@ Perl_moreswitches(pTHX_ const char *s) /* The following permits -d:Mod to accepts arguments following an = in the fashion that -MSome::Mod does. */ if (*s == ':' || *s == '=') { - const char *start = ++s; - const char *const end = s + strlen(s); - SV * const sv = newSVpvs("use Devel::"); + const char *start; + const char *end; + SV *sv; - /* We now allow -d:Module=Foo,Bar */ + if (*++s == '-') { + ++s; + sv = newSVpvs("no Devel::"); + } else { + sv = newSVpvs("use Devel::"); + } + + start = s; + end = s + strlen(s); + + /* We now allow -d:Module=Foo,Bar and -d:-Module */ while(isALNUM(*s) || *s==':') ++s; if (*s != '=') sv_catpvn(sv, start, end - start); @@ -3206,10 +3303,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 */ @@ -3234,7 +3332,7 @@ Perl_moreswitches(pTHX_ const char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2009, Larry Wall\n"); + "\n\nCopyright 1987-2011, Larry Wall\n"); #ifdef MSDOS PerlIO_printf(PerlIO_stdout(), "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); @@ -3385,14 +3483,14 @@ S_init_interp(pTHX) { dVAR; #ifdef MULTIPLICITY -# define PERLVAR(var,type) -# define PERLVARA(var,n,type) +# define PERLVAR(prefix,var,type) +# define PERLVARA(prefix,var,n,type) # if defined(PERL_IMPLICIT_CONTEXT) -# define PERLVARI(var,type,init) aTHX->var = init; -# define PERLVARIC(var,type,init) aTHX->var = init; +# define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init; +# define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init; # else -# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init; -# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARI(prefix,var,type,init) PERL_GET_INTERP->var = init; +# define PERLVARIC(prefix,var,type,init) PERL_GET_INTERP->var = init; # endif # include "intrpvar.h" # undef PERLVAR @@ -3400,10 +3498,10 @@ S_init_interp(pTHX) # undef PERLVARI # undef PERLVARIC #else -# define PERLVAR(var,type) -# define PERLVARA(var,n,type) -# define PERLVARI(var,type,init) PL_##var = init; -# define PERLVARIC(var,type,init) PL_##var = init; +# define PERLVAR(prefix,var,type) +# define PERLVARA(prefix,var,n,type) +# define PERLVARI(prefix,var,type,init) PL_##var = init; +# define PERLVARIC(prefix,var,type,init) PL_##var = init; # include "intrpvar.h" # undef PERLVAR # undef PERLVARA @@ -3632,24 +3730,21 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) /* skip forward in input to the real script? */ - while (PL_doextract) { + do { if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) Perl_croak(aTHX_ "No Perl script found in input\n"); s2 = s; - if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) { - PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ - PL_doextract = FALSE; - while (*s && !(isSPACE (*s) || *s == '#')) s++; - s2 = s; - while (*s == ' ' || *s == '\t') s++; - if (*s++ == '-') { - while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' - || s2[-1] == '_') s2--; - if (strnEQ(s2-4,"perl",4)) - while ((s = moreswitches(s))) - ; - } - } + } while (!(*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL"))))); + PerlIO_ungetc(rsfp, '\n'); /* to keep line count right */ + while (*s && !(isSPACE (*s) || *s == '#')) s++; + s2 = s; + while (*s == ' ' || *s == '\t') s++; + if (*s++ == '-') { + while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' + || s2[-1] == '_') s2--; + if (strnEQ(s2-4,"perl",4)) + while ((s = moreswitches(s))) + ; } } @@ -3744,24 +3839,42 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ } void +Perl_init_dbargs(pTHX) +{ + AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", + GV_ADDMULTI, + SVt_PVAV)))); + + if (AvREAL(args)) { + /* Someone has already created it. + It might have entries, and if we just turn off AvREAL(), they will + "leak" until global destruction. */ + av_clear(args); + } + AvREIFY_only(PL_dbargs); +} + +void Perl_init_debugger(pTHX) { dVAR; HV * const ostash = PL_curstash; PL_curstash = PL_debstash; - PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", GV_ADDMULTI, - SVt_PVAV)))); - AvREAL_off(PL_dbargs); + + Perl_init_dbargs(aTHX); PL_DBgv = gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV); PL_DBline = gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV); PL_DBsub = gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)); PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsingle, 0); + if (!SvIOK(PL_DBsingle)) + sv_setiv(PL_DBsingle, 0); PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBtrace, 0); + if (!SvIOK(PL_DBtrace)) + sv_setiv(PL_DBtrace, 0); PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); - sv_setiv(PL_DBsignal, 0); + if (!SvIOK(PL_DBsignal)) + sv_setiv(PL_DBsignal, 0); PL_curstash = ostash; } @@ -3798,6 +3911,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); @@ -3824,9 +3940,45 @@ S_nuke_stacks(pTHX) Safefree(PL_tmps_stack); Safefree(PL_markstack); Safefree(PL_scopestack); +#ifdef DEBUGGING + Safefree(PL_scopestack_name); +#endif Safefree(PL_savestack); } +void +Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) +{ + GV *const gv = gv_fetchpvn(name, len, GV_ADD | GV_ADDMULTI, SVt_PVAV); + AV *const isa = GvAVn(gv); + va_list args; + + PERL_ARGS_ASSERT_POPULATE_ISA; + + if(AvFILLp(isa) != -1) + return; + + /* NOTE: No support for tied ISA */ + + va_start(args, len); + do { + const char *const parent = va_arg(args, const char*); + size_t parent_len; + + if (!parent) + break; + parent_len = va_arg(args, size_t); + + /* Arguments are supplied with a trailing :: */ + assert(parent_len > 2); + assert(parent[parent_len - 1] == ':'); + assert(parent[parent_len - 2] == ':'); + av_push(isa, newSVpvn(parent, parent_len - 2)); + (void) gv_fetchpvn(parent, parent_len, GV_ADD, SVt_PVGV); + } while (1); + va_end(args); +} + STATIC void S_init_predump_symbols(pTHX) @@ -3838,6 +3990,26 @@ S_init_predump_symbols(pTHX) 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. + */ + + Perl_populate_isa(aTHX_ STR_WITH_LEN("IO::File::ISA"), + STR_WITH_LEN("IO::Handle::"), + STR_WITH_LEN("IO::Seekable::"), + STR_WITH_LEN("Exporter::"), + NULL); + PL_stdingv = gv_fetchpvs("STDIN", GV_ADD|GV_NOTQUAL, SVt_PVIO); GvMULTI_on(PL_stdingv); io = GvIOp(PL_stdingv); @@ -3867,9 +4039,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 @@ -3984,11 +4153,6 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register #endif /* !PERL_MICRO */ } TAINT_NOT; - if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) { - SvREADONLY_off(GvSV(tmpgv)); - sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid()); - SvREADONLY_on(GvSV(tmpgv)); - } #ifdef THREADS_HAVE_PIDS PL_ppid = (IV)getppid(); #endif @@ -4007,7 +4171,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 @@ -4048,8 +4212,12 @@ 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 + SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB */ #ifdef APPLLIB_EXP S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), @@ -4153,7 +4321,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 @@ -4178,6 +4346,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); @@ -4196,6 +4365,7 @@ S_init_perllib(pTHX) # define PERLLIB_MANGLE(s,n) (s) #endif +#ifndef PERL_IS_MINIPERL /* Push a directory onto @INC if it exists. Generate a new SV if we do this, to save needing to copy the SV we push onto @INC */ @@ -4217,11 +4387,13 @@ S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) } return dir; } +#endif STATIC void S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { dVAR; +#ifndef PERL_IS_MINIPERL const U8 using_sub_dirs = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); @@ -4232,6 +4404,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) #ifdef PERL_INC_VERSION_LIST const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; #endif +#endif const U8 canrelocate = (U8)flags & INCPUSH_CAN_RELOCATE; const U8 unshift = (U8)flags & INCPUSH_UNSHIFT; const U8 push_basedir = (flags & INCPUSH_NOT_BASEDIR) ? 0 : 1; @@ -4251,7 +4424,9 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) pushing. Hence to make it work, need to push the architecture (etc) libraries onto a temporary array, then "unshift" that onto the front of @INC. */ +#ifndef PERL_IS_MINIPERL AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; +#endif if (len) { /* I am not convinced that this is valid when PERLLIB_MANGLE is @@ -4264,6 +4439,21 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) libdir = newSVpv(PERLLIB_MANGLE(dir, 0), 0); } +#ifdef VMS + char *unix; + STRLEN len; + + if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { + len = strlen(unix); + while (unix[len-1] == '/') len--; /* Cosmetic */ + sv_usepvn(libdir,unix,len); + } + else + PerlIO_printf(Perl_error_log, + "Failed to unixify @INC element \"%s\"\n", + SvPV(libdir,len)); +#endif + /* Do the if() outside the #ifdef to avoid warnings about an unused parameter. */ if (canrelocate) { @@ -4355,7 +4545,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) libdir = tempsv; if (PL_tainting && (PL_uid != PL_euid || PL_gid != PL_egid)) { - /* Need to taint reloccated paths if running set ID */ + /* Need to taint relocated paths if running set ID */ SvTAINTED_on(libdir); } } @@ -4363,6 +4553,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) } #endif } +#ifndef PERL_IS_MINIPERL /* * BEFORE pushing libdir onto @INC we may first push version- and * archname-specific sub-directories. @@ -4374,22 +4565,6 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) const char * const incverlist[] = { PERL_INC_VERSION_LIST }; const char * const *incver; #endif -#ifdef VMS - char *unix; - STRLEN len; - - - if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { - len = strlen(unix); - while (unix[len-1] == '/') len--; /* Cosmetic */ - sv_usepvn(libdir,unix,len); - } - else - PerlIO_printf(Perl_error_log, - "Failed to unixify @INC element \"%s\"\n", - SvPV(libdir,len)); -#endif - subdir = newSVsv(libdir); if (add_versioned_sub_dirs) { @@ -4422,13 +4597,18 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) assert (SvREFCNT(subdir) == 1); SvREFCNT_dec(subdir); } - +#endif /* !PERL_IS_MINIPERL */ /* finally add this lib directory at the end of @INC */ if (unshift) { +#ifdef PERL_IS_MINIPERL + const U32 extra = 0; +#else U32 extra = av_len(av) + 1; +#endif av_unshift(inc, extra + push_basedir); if (push_basedir) av_store(inc, extra, libdir); +#ifndef PERL_IS_MINIPERL while (extra--) { /* av owns a reference, av_store() expects to be donated a reference, and av expects to be sane when it's cleared. @@ -4443,6 +4623,7 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); } SvREFCNT_dec(av); +#endif } else if (push_basedir) { av_push(inc, libdir); @@ -4465,7 +4646,15 @@ S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) PERL_ARGS_ASSERT_INCPUSH_USE_SEP; + /* perl compiled with -DPERL_RELOCATABLE_INCPUSH will ignore the len + * argument to incpush_use_sep. This allows creation of relocatable + * Perl distributions that patch the binary at install time. Those + * distributions will have to provide their own relocation tools; this + * is not a feature otherwise supported by core Perl. + */ +#ifndef PERL_RELOCATABLE_INCPUSH if (!len) +#endif len = strlen(p); end = p + len; @@ -4564,16 +4753,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: