X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/90d6a7b29f616d5e892cf7ae5d10a94c43880dae..c49a809bf96a6f9d6e8f048bb237650dc7f6ccf9:/perl.c diff --git a/perl.c b/perl.c index 5092958..8f5f7c0 100644 --- a/perl.c +++ b/perl.c @@ -2,8 +2,8 @@ /* perl.c * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 - * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 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. @@ -13,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"] */ @@ -24,6 +24,10 @@ * 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" @@ -34,15 +38,15 @@ #include "nwutil.h" #endif -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -#include +#ifdef USE_KERN_PROC_PATHNAME +# include +#endif + +#ifdef USE_NSGETEXECUTABLEPATH +# include #endif #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP -# ifdef I_SYS_WAIT -# include -# endif # ifdef I_SYSUIO # include # endif @@ -80,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); \ @@ -563,8 +561,10 @@ 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; @@ -757,7 +757,7 @@ perl_destruct(pTHXx) * 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 @@ -774,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 */ @@ -837,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 @@ -875,7 +870,6 @@ 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; @@ -911,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; @@ -997,10 +983,8 @@ perl_destruct(pTHXx) /* clear utf8 character classes */ SvREFCNT_dec(PL_utf8_alnum); - SvREFCNT_dec(PL_utf8_ascii); SvREFCNT_dec(PL_utf8_alpha); SvREFCNT_dec(PL_utf8_space); - SvREFCNT_dec(PL_utf8_cntrl); SvREFCNT_dec(PL_utf8_graph); SvREFCNT_dec(PL_utf8_digit); SvREFCNT_dec(PL_utf8_upper); @@ -1015,11 +999,10 @@ 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_ascii = NULL; PL_utf8_alpha = NULL; PL_utf8_space = NULL; - PL_utf8_cntrl = NULL; PL_utf8_graph = NULL; PL_utf8_digit = NULL; PL_utf8_upper = NULL; @@ -1034,12 +1017,13 @@ 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); @@ -1172,7 +1156,7 @@ 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" @@ -1401,54 +1385,81 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) ++PL_exitlistlen; } -#ifdef HAS_PROCSELFEXE -/* This is a function so that we don't hold on to MAXPATHLEN - bytes of stack longer than necessary - */ -STATIC void -S_procself_val(pTHX_ SV *sv, const char *arg0) -{ - char buf[MAXPATHLEN]; - int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); - - /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) - includes a spurious NUL which will cause $^X to fail in system - or backticks (this will prevent extensions from being built and - many tests from working). readlink is not meant to add a NUL. - Normal readlink works fine. - */ - if (len > 0 && buf[len-1] == '\0') { - len--; - } - - /* FreeBSD's implementation is acknowledged to be imperfect, sometimes - returning the text "unknown" from the readlink rather than the path - to the executable (or returning an error from the readlink). Any valid - path has a '/' in it somewhere, so use that to validate the result. - See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 - */ - if (len > 0 && memchr(buf, '/', len)) { - sv_setpvn(sv,buf,len); - } - else { - sv_setpv(sv,arg0); - } -} -#endif /* HAS_PROCSELFEXE */ - STATIC void S_set_caret_X(pTHX) { dVAR; GV* tmpgv = gv_fetchpvs("\030", GV_ADD|GV_NOTQUAL, SVt_PV); /* $^X */ if (tmpgv) { -#ifdef HAS_PROCSELFEXE - S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); -#else -#ifdef OS2 - sv_setpv(GvSVn(tmpgv), os2_execname(aTHX)); + SV *const caret_x = GvSV(tmpgv); +#if defined(OS2) + sv_setpv(caret_x, os2_execname(aTHX)); #else - sv_setpv(GvSVn(tmpgv),PL_origargv[0]); -#endif +# ifdef USE_KERN_PROC_PATHNAME + size_t size = 0; + int mib[4]; + mib[0] = CTL_KERN; + mib[1] = KERN_PROC; + mib[2] = KERN_PROC_PATHNAME; + mib[3] = -1; + + if (sysctl(mib, 4, NULL, &size, NULL, 0) == 0 + && size > 0 && size < MAXPATHLEN * MAXPATHLEN) { + sv_grow(caret_x, size); + + if (sysctl(mib, 4, SvPVX(caret_x), &size, NULL, 0) == 0 + && size > 2) { + SvPOK_only(caret_x); + SvCUR_set(caret_x, size - 1); + SvTAINT(caret_x); + return; + } + } +# elif defined(USE_NSGETEXECUTABLEPATH) + char buf[1]; + uint32_t size = sizeof(buf); + + _NSGetExecutablePath(buf, &size); + if (size < MAXPATHLEN * MAXPATHLEN) { + sv_grow(caret_x, size); + if (_NSGetExecutablePath(SvPVX(caret_x), &size) == 0) { + char *const tidied = realpath(SvPVX(caret_x), NULL); + if (tidied) { + sv_setpv(caret_x, tidied); + free(tidied); + } else { + SvPOK_only(caret_x); + SvCUR_set(caret_x, size); + } + return; + } + } +# elif defined(HAS_PROCSELFEXE) + char buf[MAXPATHLEN]; + int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1); + + /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe) + includes a spurious NUL which will cause $^X to fail in system + or backticks (this will prevent extensions from being built and + many tests from working). readlink is not meant to add a NUL. + Normal readlink works fine. + */ + if (len > 0 && buf[len-1] == '\0') { + len--; + } + + /* FreeBSD's implementation is acknowledged to be imperfect, sometimes + returning the text "unknown" from the readlink rather than the path + to the executable (or returning an error from the readlink). Any + valid path has a '/' in it somewhere, so use that to validate the + result. See http://www.freebsd.org/cgi/query-pr.cgi?pr=35703 + */ + if (len > 0 && memchr(buf, '/', len)) { + sv_setpvn(caret_x, buf, len); + return; + } +# endif + /* Fallback to this: */ + sv_setpv(caret_x, PL_origargv[0]); #endif } } @@ -1477,7 +1488,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) @@ -1615,10 +1626,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: @@ -1630,10 +1644,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: @@ -1665,6 +1682,9 @@ S_Internals_V(pTHX_ CV *cv) # ifdef DEBUGGING " DEBUGGING" # endif +# ifdef HOMEGROWN_POSIX_SIGNALS + " HOMEGROWN_POSIX_SIGNALS" +# endif # ifdef NO_MATHOMS " NO_MATHOMS" # endif @@ -1689,18 +1709,30 @@ S_Internals_V(pTHX_ CV *cv) # 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 @@ -1757,6 +1789,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; @@ -1764,6 +1797,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,""); @@ -1885,7 +1920,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; } case 'x': - PL_doextract = TRUE; + doextract = TRUE; s++; if (*s) cddir = s; @@ -1972,15 +2007,26 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } -#if defined(USE_SITECUSTOMIZE) && !defined(PERL_IS_MINIPERL) +#if defined(USE_SITECUSTOMIZE) if (!minus_f) { - /* SITELIB_EXP is a function call on Win32. - The games with local $! are to avoid setting errno if there is no + /* 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 {local $!; -f '%s/sitecustomize.pl'} && do '%s/sitecustomize.pl' }", sitelib, sitelib)); +# endif } #endif @@ -2029,7 +2075,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) # endif #endif - if (PL_doextract) { + if (doextract) { /* This will croak if suidscript is true, as -x cannot be used with setuid scripts. */ @@ -2163,7 +2209,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) @@ -2254,8 +2300,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: "); @@ -2304,8 +2352,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 @@ -2313,6 +2363,8 @@ S_run_body(pTHX_ I32 oldscope) /* do it */ + PERL_SET_PHASE(PERL_PHASE_RUN); + if (PL_restartop) { PL_restartjmpenv = NULL; PL_op = PL_restartop; @@ -2359,11 +2411,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 */ @@ -2465,7 +2520,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 */ @@ -2672,7 +2730,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 */ @@ -2720,7 +2779,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(); @@ -2743,6 +2807,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PL_restartop = 0; goto redo_body; } + fail: PL_stack_sp = PL_stack_base + oldmark; if ((flags & G_WANT) == G_ARRAY) retval = 0; @@ -3034,11 +3099,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; + + 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 */ + /* We now allow -d:Module=Foo,Bar and -d:-Module */ while(isALNUM(*s) || *s==':') ++s; if (*s != '=') sv_catpvn(sv, start, end - start); @@ -3280,7 +3355,7 @@ Perl_moreswitches(pTHX_ const char *s) #endif PerlIO_printf(PerlIO_stdout(), - "\n\nCopyright 1987-2010, 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"); @@ -3431,14 +3506,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 @@ -3446,10 +3521,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 @@ -3678,24 +3753,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))) + ; } } @@ -3802,7 +3874,7 @@ Perl_init_dbargs(pTHX) "leak" until global destruction. */ av_clear(args); } - AvREAL_off(PL_dbargs); /* XXX should be REIFY (see av.h) */ + AvREIFY_only(PL_dbargs); } void @@ -3897,6 +3969,39 @@ S_nuke_stacks(pTHX) 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) @@ -3904,7 +4009,6 @@ 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)); @@ -3923,14 +4027,11 @@ S_init_predump_symbols(pTHX) 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); - + 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); @@ -4075,11 +4176,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 @@ -4292,6 +4388,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 */ @@ -4313,11 +4410,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); @@ -4328,6 +4427,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; @@ -4347,7 +4447,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 @@ -4360,6 +4462,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) { @@ -4451,7 +4568,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); } } @@ -4459,6 +4576,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. @@ -4470,22 +4588,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) { @@ -4518,13 +4620,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. @@ -4539,6 +4646,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); @@ -4561,7 +4669,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;