X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/61e2287f1d50036b5c34917b93d23030d05ec1b5..HEAD:/perl.c diff --git a/perl.c b/perl.c index 54edaf5..d97a603 100644 --- a/perl.c +++ b/perl.c @@ -3,7 +3,9 @@ * * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 * 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 - * 2013, 2014, 2015, 2016, 2017 by Larry Wall and others + * 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022, 2023 + * 2024 + * 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. @@ -38,10 +40,6 @@ #include "patchlevel.h" /* for local_patches */ #include "XSUB.h" -#ifdef NETWARE -#include "nwutil.h" -#endif - #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP # ifdef I_SYSUIO # include @@ -70,12 +68,6 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); # define validate_suid(rsfp) S_validate_suid(aTHX_ rsfp) #endif -#define CALL_BODY_SUB(myop) \ - if (PL_op == (myop)) \ - PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \ - if (PL_op) \ - CALLRUNOPS(aTHX); - #define CALL_LIST_BODY(cv) \ PUSHMARK(PL_stack_sp); \ call_sv(MUTABLE_SV((cv)), G_EVAL|G_DISCARD|G_VOID); @@ -83,19 +75,21 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); static void S_init_tls_and_interp(PerlInterpreter *my_perl) { - dVAR; - if (!PL_curinterp) { - PERL_SET_INTERP(my_perl); + if (!PL_curinterp) { + PERL_SET_INTERP(my_perl); #if defined(USE_ITHREADS) - INIT_THREADS; - ALLOC_THREAD_KEY; - PERL_SET_THX(my_perl); - OP_REFCNT_INIT; - OP_CHECK_MUTEX_INIT; - HINTS_REFCNT_INIT; + INIT_THREADS; + ALLOC_THREAD_KEY; + PERL_SET_THX(my_perl); + OP_REFCNT_INIT; + OP_CHECK_MUTEX_INIT; + KEYWORD_PLUGIN_MUTEX_INIT; + HINTS_REFCNT_INIT; LOCALE_INIT; - MUTEX_INIT(&PL_dollarzero_mutex); - MUTEX_INIT(&PL_my_ctx_mutex); + USER_PROP_MUTEX_INIT; + ENV_INIT; + MUTEX_INIT(&PL_dollarzero_mutex); + MUTEX_INIT(&PL_my_ctx_mutex); # endif } #if defined(USE_ITHREADS) @@ -104,17 +98,44 @@ S_init_tls_and_interp(PerlInterpreter *my_perl) /* This always happens for non-ithreads */ #endif { - PERL_SET_THX(my_perl); + PERL_SET_THX(my_perl); } } +#ifndef PLATFORM_SYS_INIT_ +# define PLATFORM_SYS_INIT_ NOOP +#endif + +#ifndef PLATFORM_SYS_TERM_ +# define PLATFORM_SYS_TERM_ NOOP +#endif + +#ifndef PERL_SYS_INIT_BODY +# define PERL_SYS_INIT_BODY(c,v) \ + MALLOC_CHECK_TAINT2(*c,*v) PERL_FPU_INIT; PERLIO_INIT; \ + MALLOC_INIT; PLATFORM_SYS_INIT_; +#endif + +/* Generally add things last-in first-terminated. IO and memory terminations + * need to be generally last + * + * BEWARE that using PerlIO in these will be using freed memory, so may appear + * to work, but must NOT be retained in production code. */ +#ifndef PERL_SYS_TERM_BODY +# define PERL_SYS_TERM_BODY() \ + ENV_TERM; USER_PROP_MUTEX_TERM; LOCALE_TERM; \ + HINTS_REFCNT_TERM; KEYWORD_PLUGIN_MUTEX_TERM; \ + OP_CHECK_MUTEX_TERM; OP_REFCNT_TERM; \ + PERLIO_TERM; MALLOC_TERM; \ + PLATFORM_SYS_TERM_; +#endif + /* these implement the PERL_SYS_INIT, PERL_SYS_INIT3, PERL_SYS_TERM macros */ void Perl_sys_init(int* argc, char*** argv) { - dVAR; PERL_ARGS_ASSERT_SYS_INIT; @@ -126,7 +147,6 @@ Perl_sys_init(int* argc, char*** argv) void Perl_sys_init3(int* argc, char*** argv, char*** env) { - dVAR; PERL_ARGS_ASSERT_SYS_INIT3; @@ -139,9 +159,8 @@ Perl_sys_init3(int* argc, char*** argv, char*** env) void Perl_sys_term(void) { - dVAR; if (!PL_veto_cleanup) { - PERL_SYS_TERM_BODY(); + PERL_SYS_TERM_BODY(); } } @@ -149,19 +168,18 @@ Perl_sys_term(void) #ifdef PERL_IMPLICIT_SYS PerlInterpreter * perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, - struct IPerlMem* ipMP, struct IPerlEnv* ipE, - struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, - struct IPerlDir* ipD, struct IPerlSock* ipS, - struct IPerlProc* ipP) + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) { PerlInterpreter *my_perl; PERL_ARGS_ASSERT_PERL_ALLOC_USING; /* Newx() needs interpreter, so call malloc() instead */ - my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + my_perl = (PerlInterpreter*)(*ipM->pCalloc)(ipM, 1, sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); - Zero(my_perl, 1, PerlInterpreter); PL_Mem = ipM; PL_MemShared = ipMS; PL_MemParse = ipMP; @@ -178,7 +196,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, #else /* -=head1 Embedding Functions +=for apidoc_section $embedding =for apidoc perl_alloc @@ -190,19 +208,11 @@ Allocates a new Perl interpreter. See L. PerlInterpreter * perl_alloc(void) { - PerlInterpreter *my_perl; - - /* Newx() needs interpreter, so call malloc() instead */ - my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_calloc(1, sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); -#ifndef PERL_TRACK_MEMPOOL - return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter); -#else - Zero(my_perl, 1, PerlInterpreter); INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl); return my_perl; -#endif } #endif /* PERL_IMPLICIT_SYS */ @@ -214,30 +224,9 @@ Initializes a new Perl interpreter. See L. =cut */ -static void -S_fixup_platform_bugs(void) -{ -#if defined(__GLIBC__) && IVSIZE == 8 \ - && ( __GLIBC__ < 2 || (__GLIBC__ == 2 && __GLIBC_MINOR__ < 8)) - { - IV l = 3; - IV r = -10; - /* Cannot do this check with inlined IV constants since - * that seems to work correctly even with the buggy glibc. */ - if (l % r == -3) { - dTHX; - /* Yikes, we have the bug. - * Patch in the workaround version. */ - PL_ppaddr[OP_I_MODULO] = &Perl_pp_i_modulo_glibc_bugfix; - } - } -#endif -} - void perl_construct(pTHXx) { - dVAR; PERL_ARGS_ASSERT_PERL_CONSTRUCT; @@ -260,7 +249,10 @@ perl_construct(pTHXx) SvREADONLY_on(&PL_sv_placeholder); SvREFCNT(&PL_sv_placeholder) = SvREFCNT_IMMORTAL; - PL_sighandlerp = (Sighandler_t) Perl_sighandler; + PL_sighandlerp = Perl_sighandler; + PL_sighandler1p = Perl_sighandler1; + PL_sighandler3p = Perl_sighandler3; + #ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); #endif @@ -269,20 +261,43 @@ perl_construct(pTHXx) init_stacks(); -/* The PERL_INTERNAL_RAND_SEED set-up must be after init_stacks because it calls +#if !defined(NO_PERL_RAND_SEED) || !defined(NO_PERL_INTERNAL_HASH_SEED) + bool sensitive_env_vars_allowed = + (PerlProc_getuid() == PerlProc_geteuid() && + PerlProc_getgid() == PerlProc_getegid()) ? TRUE : FALSE; +#endif + +/* The seed set-up must be after init_stacks because it calls * things that may put SVs on the stack. */ +#ifndef NO_PERL_RAND_SEED + if (sensitive_env_vars_allowed) { + UV seed= 0; + const char *env_pv; + if ((env_pv = PerlEnv_getenv("PERL_RAND_SEED")) && + grok_number(env_pv, strlen(env_pv), &seed) == IS_NUMBER_IN_UV) + { + + PL_srand_override_next = seed; + PERL_SRAND_OVERRIDE_NEXT_INIT(); + } + } +#endif + /* This is NOT the state used for C, this is only + * used in internal functionality */ #ifdef NO_PERL_INTERNAL_RAND_SEED Perl_drand48_init_r(&PL_internal_random_state, seed()); #else { UV seed; const char *env_pv; - if (PerlProc_getuid() != PerlProc_geteuid() || - PerlProc_getgid() != PerlProc_getegid() || + if ( + !sensitive_env_vars_allowed || !(env_pv = PerlEnv_getenv("PERL_INTERNAL_RAND_SEED")) || - grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) { + grok_number(env_pv, strlen(env_pv), &seed) != IS_NUMBER_IN_UV) + { + /* use a randomly generated seed */ seed = seed(); } Perl_drand48_init_r(&PL_internal_random_state, (U32)seed); @@ -291,12 +306,13 @@ perl_construct(pTHXx) init_ids(); - S_fixup_platform_bugs(); - JMPENV_BOOTSTRAP; STATUS_ALL_SUCCESS; - init_i18nl10n(1); + init_uniprops(); + (void) uvchr_to_utf8_flags((U8 *) PL_TR_SPECIAL_HANDLING_UTF8, + TR_SPECIAL_HANDLING, + UNICODE_ALLOW_ABOVE_IV_MAX); #if defined(LOCAL_PATCH_COUNT) PL_localpatches = local_patches; /* For possible -v */ @@ -367,26 +383,35 @@ perl_construct(pTHXx) PERL_HASH_WITH_STATE(PL_hash_state,PL_hash_chars[256],str,0); } #endif - /* at this point we have initialezed the hash function, and we can start + /* at this point we have initialized the hash function, and we can start * constructing hashes */ PL_hash_seed_set= TRUE; } - /* Note that strtab is a rather special HV. Assumptions are made - about not iterating on it, and not adding tie magic to it. - It is properly deallocated in perl_destruct() */ - PL_strtab = newHV(); - /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab, - * which is not the case with PL_strtab itself */ - HvSHAREKEYS_off(PL_strtab); /* mandatory */ - hv_ksplit(PL_strtab, 1 << 11); + /* Allow PL_strtab to be pre-initialized before calling perl_construct. + * can use a custom optimized PL_strtab hash before calling perl_construct */ + if (!PL_strtab) { + /* Note that strtab is a rather special HV. Assumptions are made + about not iterating on it, and not adding tie magic to it. + It is properly deallocated in perl_destruct() */ + PL_strtab = newHV(); + + /* SHAREKEYS tells us that the hash has its keys shared with PL_strtab, + * which is not the case with PL_strtab itself */ + HvSHAREKEYS_off(PL_strtab); /* mandatory */ + hv_ksplit(PL_strtab, 1 << 11); + } + +#ifdef USE_ITHREADS + PL_compiling.cop_file = NULL; + PL_compiling.cop_warnings = NULL; +#endif Zero(PL_sv_consts, SV_CONSTS_COUNT, SV*); -#ifndef PERL_MICRO -# ifdef USE_ENVIRON_ARRAY - PL_origenviron = environ; -# endif +#ifdef USE_ENVIRON_ARRAY + if (!PL_origenviron) + PL_origenviron = environ; #endif /* Use sysconf(_SC_CLK_TCK) if available, if not @@ -397,7 +422,7 @@ perl_construct(pTHXx) PL_clocktick = sysconf(_SC_CLK_TCK); if (PL_clocktick <= 0) #endif - PL_clocktick = HZ; + PL_clocktick = HZ; PL_stashcache = newHV(); @@ -407,21 +432,16 @@ perl_construct(pTHXx) if (!PL_mmap_page_size) { #if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE)) { - SETERRNO(0, SS_NORMAL); + SETERRNO(0, SS_NORMAL); # ifdef _SC_PAGESIZE - PL_mmap_page_size = sysconf(_SC_PAGESIZE); + PL_mmap_page_size = sysconf(_SC_PAGESIZE); # else - PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); + PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE); # endif - if ((long) PL_mmap_page_size < 0) { - if (errno) { - SV * const error = ERRSV; - SvUPGRADE(error, SVt_PV); - Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); - } - else - Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); - } + if ((long) PL_mmap_page_size < 0) { + Perl_croak(aTHX_ "panic: sysconf: %s", + errno ? Strerror(errno) : "pagesize unknown"); + } } #elif defined(HAS_GETPAGESIZE) PL_mmap_page_size = getpagesize(); @@ -429,50 +449,19 @@ perl_construct(pTHXx) PL_mmap_page_size = PAGESIZE; /* compiletime, bad */ #endif if (PL_mmap_page_size <= 0) - Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, - (IV) PL_mmap_page_size); + Perl_croak(aTHX_ "panic: bad pagesize %" IVdf, + (IV) PL_mmap_page_size); } #endif /* HAS_MMAP */ -#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE) - PL_timesbase.tms_utime = 0; - PL_timesbase.tms_stime = 0; - PL_timesbase.tms_cutime = 0; - 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; - PL_XPosix_ptrs[_CC_ASCII] = _new_invlist_C_array(ASCII_invlist); - PL_XPosix_ptrs[_CC_ALPHANUMERIC] = _new_invlist_C_array(XPosixAlnum_invlist); - PL_XPosix_ptrs[_CC_ALPHA] = _new_invlist_C_array(XPosixAlpha_invlist); - PL_XPosix_ptrs[_CC_BLANK] = _new_invlist_C_array(XPosixBlank_invlist); - PL_XPosix_ptrs[_CC_CASED] = _new_invlist_C_array(Cased_invlist); - PL_XPosix_ptrs[_CC_CNTRL] = _new_invlist_C_array(XPosixCntrl_invlist); - PL_XPosix_ptrs[_CC_DIGIT] = _new_invlist_C_array(XPosixDigit_invlist); - PL_XPosix_ptrs[_CC_GRAPH] = _new_invlist_C_array(XPosixGraph_invlist); - PL_XPosix_ptrs[_CC_LOWER] = _new_invlist_C_array(XPosixLower_invlist); - PL_XPosix_ptrs[_CC_PRINT] = _new_invlist_C_array(XPosixPrint_invlist); - PL_XPosix_ptrs[_CC_PUNCT] = _new_invlist_C_array(XPosixPunct_invlist); - PL_XPosix_ptrs[_CC_SPACE] = _new_invlist_C_array(XPerlSpace_invlist); - PL_XPosix_ptrs[_CC_UPPER] = _new_invlist_C_array(XPosixUpper_invlist); - PL_XPosix_ptrs[_CC_VERTSPACE] = _new_invlist_C_array(VertSpace_invlist); - PL_XPosix_ptrs[_CC_WORDCHAR] = _new_invlist_C_array(XPosixWord_invlist); - PL_XPosix_ptrs[_CC_XDIGIT] = _new_invlist_C_array(XPosixXDigit_invlist); - PL_GCB_invlist = _new_invlist_C_array(_Perl_GCB_invlist); - PL_SB_invlist = _new_invlist_C_array(_Perl_SB_invlist); - PL_WB_invlist = _new_invlist_C_array(_Perl_WB_invlist); - PL_LB_invlist = _new_invlist_C_array(_Perl_LB_invlist); - PL_Assigned_invlist = _new_invlist_C_array(Assigned_invlist); -#ifdef HAS_POSIX_2008_LOCALE - PL_C_locale_obj = newlocale(LC_ALL_MASK, "C", NULL); -#endif - ENTER; + init_i18nl10n(1); } /* @@ -508,7 +497,7 @@ Perl_dump_sv_child(pTHX_ SV *sv) PERL_ARGS_ASSERT_DUMP_SV_CHILD; if(sock == -1 || debug_fd == -1) - return; + return; PerlIO_flush(Perl_debug_log); @@ -537,12 +526,12 @@ Perl_dump_sv_child(pTHX_ SV *sv) got = sendmsg(sock, &msg, 0); if(got < 0) { - perror("Debug leaking scalars parent sendmsg failed"); - abort(); + perror("Debug leaking scalars parent sendmsg failed"); + abort(); } if(got < sizeof(sv)) { - perror("Debug leaking scalars parent short sendmsg"); - abort(); + perror("Debug leaking scalars parent short sendmsg"); + abort(); } /* Return protocol is @@ -558,35 +547,35 @@ Perl_dump_sv_child(pTHX_ SV *sv) got = readv(sock, vec, 2); if(got < 0) { - perror("Debug leaking scalars parent read failed"); - PerlIO_flush(PerlIO_stderr()); - abort(); + perror("Debug leaking scalars parent read failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); } if(got < sizeof(returned_errno) + 1) { - perror("Debug leaking scalars parent short read"); - PerlIO_flush(PerlIO_stderr()); - abort(); + perror("Debug leaking scalars parent short read"); + PerlIO_flush(PerlIO_stderr()); + abort(); } if (*buffer) { - got = read(sock, buffer + 1, *buffer); - if(got < 0) { - perror("Debug leaking scalars parent read 2 failed"); - PerlIO_flush(PerlIO_stderr()); - abort(); - } + got = read(sock, buffer + 1, *buffer); + if(got < 0) { + perror("Debug leaking scalars parent read 2 failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } - if(got < *buffer) { - perror("Debug leaking scalars parent short read 2"); - PerlIO_flush(PerlIO_stderr()); - abort(); - } + if(got < *buffer) { + perror("Debug leaking scalars parent short read 2"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } } if (returned_errno || *buffer) { - Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" - " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, - returned_errno, Strerror(returned_errno)); + Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" + " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, + returned_errno, Strerror(returned_errno)); } } #endif @@ -594,7 +583,31 @@ Perl_dump_sv_child(pTHX_ SV *sv) /* =for apidoc perl_destruct -Shuts down a Perl interpreter. See L. +Shuts down a Perl interpreter. See L for a tutorial. + +C points to the Perl interpreter. It must have been previously +created through the use of L and L. It may +have been initialised through L, and may have been used +through L and other means. This function should be called for +any Perl interpreter that has been constructed with L, +even if subsequent operations on it failed, for example if L +returned a non-zero value. + +If the interpreter's C word has the +C flag set, then this function will execute code +in C blocks before performing the rest of destruction. If it is +desired to make any use of the interpreter between L and +L other than just calling L, then this flag +should be set early on. This matters if L will not be called, +or if anything else will be done in addition to calling L. + +Returns a value be a suitable value to pass to the C library function +C (or to return from C
), to serve as an exit code indicating +the nature of the way the interpreter terminated. This takes into account +any failure of L and any early exit from L. +The exit code is of the type required by the host operating system, +so because of differing exit code conventions it is not portable to +interpret specific numeric values as having specific meanings. =cut */ @@ -602,7 +615,6 @@ Shuts down a Perl interpreter. See L. int perl_destruct(pTHXx) { - dVAR; volatile signed char destruct_level; /* see possible values in intrpvar.h */ HV *hv; #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP @@ -617,14 +629,10 @@ perl_destruct(pTHXx) assert(PL_scopestack_ix == 1); - /* wait for all pseudo-forked children to finish */ - PERL_WAIT_FOR_CHILDREN; - destruct_level = PL_perl_destruct_level; -#if defined(DEBUGGING) || defined(PERL_TRACK_MEMPOOL) { - const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); - if (s) { + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (s) { int i; if (strEQ(s, "-1")) { /* Special case: modperl folklore. */ i = -1; @@ -635,33 +643,49 @@ perl_destruct(pTHXx) else i = 0; } -#ifdef DEBUGGING - if (destruct_level < i) destruct_level = i; -#endif + if (destruct_level < i) destruct_level = i; #ifdef PERL_TRACK_MEMPOOL /* RT #114496, for perl_free */ PL_perl_destruct_level = i; #endif - } + } } -#endif if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) { dJMPENV; int x = 0; JMPENV_PUSH(x); - PERL_UNUSED_VAR(x); + PERL_UNUSED_VAR(x); if (PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); + PERL_SET_PHASE(PERL_PHASE_END); call_list(PL_scopestack_ix, PL_endav); - } + } JMPENV_POP; } LEAVE; FREETMPS; assert(PL_scopestack_ix == 0); + /* wait for all pseudo-forked children to finish */ + PERL_WAIT_FOR_CHILDREN; + + + /* normally when we get here, PL_parser should be null due to having + * its original (null) value restored by SAVEt_PARSER during leaving + * scope (usually before run-time starts in fact). + * But if a thread is created within a BEGIN block, the parser is + * duped, but the SAVEt_PARSER savestack entry isn't. So PL_parser + * never gets cleaned up. + * Clean it up here instead. This is a bit of a hack. + */ + if (PL_parser) { + /* stop parser_free() stomping on PL_curcop */ + PL_parser->saved_curcop = PL_curcop; + parser_free(PL_parser); + } + + /* Need to flush since END blocks can produce output */ /* flush stdout separately, since we can identify it */ #ifdef USE_PERLIO @@ -670,7 +694,7 @@ perl_destruct(pTHXx) if (*stdo && PerlIO_flush(stdo)) { PerlIO_restore_errno(stdo); if (errno) - PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s", + PerlIO_printf(PerlIO_stderr(), "Unable to flush stdout: %s\n", Strerror(errno)); if (!STATUS_UNIX) STATUS_ALL_FAILURE; @@ -704,164 +728,164 @@ perl_destruct(pTHXx) if (PL_threadhook(aTHX)) { /* Threads hook has vetoed further cleanup */ - PL_veto_cleanup = TRUE; + PL_veto_cleanup = TRUE; return STATUS_EXIT; } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP if (destruct_level != 0) { - /* Fork here to create a child. Our child's job is to preserve the - state of scalars prior to destruction, so that we can instruct it - to dump any scalars that we later find have leaked. - There's no subtlety in this code - it assumes POSIX, and it doesn't - fail gracefully */ - int fd[2]; - - if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) { - perror("Debug leaking scalars socketpair failed"); - abort(); - } - - child = fork(); - if(child == -1) { - perror("Debug leaking scalars fork failed"); - abort(); - } - if (!child) { - /* We are the child */ - const int sock = fd[1]; - const int debug_fd = PerlIO_fileno(Perl_debug_log); - int f; - const char *where; - /* Our success message is an integer 0, and a char 0 */ - static const char success[sizeof(int) + 1] = {0}; - - close(fd[0]); - - /* We need to close all other file descriptors otherwise we end up - with interesting hangs, where the parent closes its end of a - pipe, and sits waiting for (another) child to terminate. Only - that child never terminates, because it never gets EOF, because - we also have the far end of the pipe open. We even need to - close the debugging fd, because sometimes it happens to be one - end of a pipe, and a process is waiting on the other end for - EOF. Normally it would be closed at some point earlier in - destruction, but if we happen to cause the pipe to remain open, - EOF never occurs, and we get an infinite hang. Hence all the - games to pass in a file descriptor if it's actually needed. */ - - f = sysconf(_SC_OPEN_MAX); - if(f < 0) { - where = "sysconf failed"; - goto abort; - } - while (f--) { - if (f == sock) - continue; - close(f); - } - - while (1) { - SV *target; - union control_un control; - struct msghdr msg; - struct iovec vec[1]; - struct cmsghdr *cmptr; - ssize_t got; - int got_fd; - - msg.msg_control = control.control; - msg.msg_controllen = sizeof(control.control); - /* We're a connected socket so we don't need a source */ - msg.msg_name = NULL; - msg.msg_namelen = 0; - msg.msg_iov = vec; - msg.msg_iovlen = C_ARRAY_LENGTH(vec); - - vec[0].iov_base = (void*)⌖ - vec[0].iov_len = sizeof(target); - - got = recvmsg(sock, &msg, 0); - - if(got == 0) - break; - if(got < 0) { - where = "recv failed"; - goto abort; - } - if(got < sizeof(target)) { - where = "short recv"; - goto abort; - } - - if(!(cmptr = CMSG_FIRSTHDR(&msg))) { - where = "no cmsg"; - goto abort; - } - if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { - where = "wrong cmsg_len"; - goto abort; - } - if(cmptr->cmsg_level != SOL_SOCKET) { - where = "wrong cmsg_level"; - goto abort; - } - if(cmptr->cmsg_type != SCM_RIGHTS) { - where = "wrong cmsg_type"; - goto abort; - } - - got_fd = *(int*)CMSG_DATA(cmptr); - /* For our last little bit of trickery, put the file descriptor - back into Perl_debug_log, as if we never actually closed it - */ - if(got_fd != debug_fd) { - if (dup2(got_fd, debug_fd) == -1) { - where = "dup2"; - goto abort; - } - } - sv_dump(target); - - PerlIO_flush(Perl_debug_log); - - got = write(sock, &success, sizeof(success)); - - if(got < 0) { - where = "write failed"; - goto abort; - } - if(got < sizeof(success)) { - where = "short write"; - goto abort; - } - } - _exit(0); - abort: - { - int send_errno = errno; - unsigned char length = (unsigned char) strlen(where); - struct iovec failure[3] = { - {(void*)&send_errno, sizeof(send_errno)}, - {&length, 1}, - {(void*)where, length} - }; - int got = writev(sock, failure, 3); - /* Bad news travels fast. Faster than data. We'll get a SIGPIPE - in the parent if we try to read from the socketpair after the - child has exited, even if there was data to read. - So sleep a bit to give the parent a fighting chance of - reading the data. */ - sleep(2); - _exit((got == -1) ? errno : 0); - } - /* End of child. */ - } - PL_dumper_fd = fd[0]; - close(fd[1]); - } -#endif - + /* Fork here to create a child. Our child's job is to preserve the + state of scalars prior to destruction, so that we can instruct it + to dump any scalars that we later find have leaked. + There's no subtlety in this code - it assumes POSIX, and it doesn't + fail gracefully */ + int fd[2]; + + if(PerlSock_socketpair_cloexec(AF_UNIX, SOCK_STREAM, 0, fd)) { + perror("Debug leaking scalars socketpair failed"); + abort(); + } + + child = fork(); + if(child == -1) { + perror("Debug leaking scalars fork failed"); + abort(); + } + if (!child) { + /* We are the child */ + const int sock = fd[1]; + const int debug_fd = PerlIO_fileno(Perl_debug_log); + int f; + const char *where; + /* Our success message is an integer 0, and a char 0 */ + static const char success[sizeof(int) + 1] = {0}; + + close(fd[0]); + + /* We need to close all other file descriptors otherwise we end up + with interesting hangs, where the parent closes its end of a + pipe, and sits waiting for (another) child to terminate. Only + that child never terminates, because it never gets EOF, because + we also have the far end of the pipe open. We even need to + close the debugging fd, because sometimes it happens to be one + end of a pipe, and a process is waiting on the other end for + EOF. Normally it would be closed at some point earlier in + destruction, but if we happen to cause the pipe to remain open, + EOF never occurs, and we get an infinite hang. Hence all the + games to pass in a file descriptor if it's actually needed. */ + + f = sysconf(_SC_OPEN_MAX); + if(f < 0) { + where = "sysconf failed"; + goto abort; + } + while (f--) { + if (f == sock) + continue; + close(f); + } + + while (1) { + SV *target; + union control_un control; + struct msghdr msg; + struct iovec vec[1]; + struct cmsghdr *cmptr; + ssize_t got; + int got_fd; + + msg.msg_control = control.control; + msg.msg_controllen = sizeof(control.control); + /* We're a connected socket so we don't need a source */ + msg.msg_name = NULL; + msg.msg_namelen = 0; + msg.msg_iov = vec; + msg.msg_iovlen = C_ARRAY_LENGTH(vec); + + vec[0].iov_base = (void*)⌖ + vec[0].iov_len = sizeof(target); + + got = recvmsg(sock, &msg, 0); + + if(got == 0) + break; + if(got < 0) { + where = "recv failed"; + goto abort; + } + if(got < sizeof(target)) { + where = "short recv"; + goto abort; + } + + if(!(cmptr = CMSG_FIRSTHDR(&msg))) { + where = "no cmsg"; + goto abort; + } + if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { + where = "wrong cmsg_len"; + goto abort; + } + if(cmptr->cmsg_level != SOL_SOCKET) { + where = "wrong cmsg_level"; + goto abort; + } + if(cmptr->cmsg_type != SCM_RIGHTS) { + where = "wrong cmsg_type"; + goto abort; + } + + got_fd = *(int*)CMSG_DATA(cmptr); + /* For our last little bit of trickery, put the file descriptor + back into Perl_debug_log, as if we never actually closed it + */ + if(got_fd != debug_fd) { + if (PerlLIO_dup2_cloexec(got_fd, debug_fd) == -1) { + where = "dup2"; + goto abort; + } + } + sv_dump(target); + + PerlIO_flush(Perl_debug_log); + + got = write(sock, &success, sizeof(success)); + + if(got < 0) { + where = "write failed"; + goto abort; + } + if(got < sizeof(success)) { + where = "short write"; + goto abort; + } + } + _exit(0); + abort: + { + int send_errno = errno; + unsigned char length = (unsigned char) strlen(where); + struct iovec failure[3] = { + {(void*)&send_errno, sizeof(send_errno)}, + {&length, 1}, + {(void*)where, length} + }; + int got = writev(sock, failure, 3); + /* Bad news travels fast. Faster than data. We'll get a SIGPIPE + in the parent if we try to read from the socketpair after the + child has exited, even if there was data to read. + So sleep a bit to give the parent a fighting chance of + reading the data. */ + sleep(2); + _exit((got == -1) ? errno : 0); + } + /* End of child. */ + } + PL_dumper_fd = fd[0]; + close(fd[1]); + } +#endif + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ @@ -871,13 +895,13 @@ perl_destruct(pTHXx) op from which the filename structure member is copied. */ PL_curcop = &PL_compiling; if (PL_main_root) { - /* ensure comppad/curpad to refer to main's pad */ - if (CvPADLIST(PL_main_cv)) { - PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); - PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); - } - op_free(PL_main_root); - PL_main_root = NULL; + /* ensure comppad/curpad to refer to main's pad */ + if (CvPADLIST(PL_main_cv)) { + PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1); + PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv)); + } + op_free(PL_main_root); + PL_main_root = NULL; } PL_main_start = NULL; /* note that PL_main_cv isn't usually actually freed at this point, @@ -907,10 +931,14 @@ perl_destruct(pTHXx) PL_warnhook = NULL; SvREFCNT_dec(PL_diehook); PL_diehook = NULL; + SvREFCNT_dec(PL_hook__require__before); + PL_hook__require__before = NULL; + SvREFCNT_dec(PL_hook__require__after); + PL_hook__require__after = NULL; /* call exit list functions */ while (PL_exitlistlen-- > 0) - PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); + PL_exitlist[PL_exitlistlen].fn(aTHX_ PL_exitlist[PL_exitlistlen].ptr); Safefree(PL_exitlist); @@ -919,44 +947,18 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_registered_mros); - /* jettison our possibly duplicated environment */ - /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied - * so we certainly shouldn't free it here - */ -#ifndef PERL_MICRO -#if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV) - if (environ != PL_origenviron && !PL_use_safe_putenv -#ifdef USE_ITHREADS - /* only main thread can free environ[0] contents */ - && PL_curinterp == aTHX -#endif - ) - { - I32 i; - - for (i = 0; environ[i]; i++) - safesysfree(environ[i]); - - /* Must use safesysfree() when working with environ. */ - safesysfree(environ); - - environ = PL_origenviron; - } -#endif -#endif /* !PERL_MICRO */ - if (destruct_level == 0) { - DEBUG_P(debprofdump()); + DEBUG_P(debprofdump()); #if defined(PERLIO_LAYERS) - /* No more IO - including error messages ! */ - PerlIO_cleanup(aTHX); + /* No more IO - including error messages ! */ + PerlIO_cleanup(aTHX); #endif - CopFILE_free(&PL_compiling); + CopFILE_free(&PL_compiling); - /* The exit() function will do everything that needs doing. */ + /* The exit() function will do everything that needs doing. */ return STATUS_EXIT; } @@ -969,13 +971,13 @@ perl_destruct(pTHXx) * we need to manually ReREFCNT_dec for the clones */ { - I32 i = AvFILLp(PL_regex_padav); - SV **ary = AvARRAY(PL_regex_padav); + I32 i = AvFILLp(PL_regex_padav); + SV **ary = AvARRAY(PL_regex_padav); - for (; i; i--) { - SvREFCNT_dec(ary[i]); - ary[i] = &PL_sv_undef; - } + for (; i; i--) { + SvREFCNT_dec(ary[i]); + ary[i] = &PL_sv_undef; + } } #endif @@ -987,13 +989,13 @@ perl_destruct(pTHXx) /* XXX can PL_parser still be non-null here? */ if(PL_parser && PL_parser->rsfp) { - (void)PerlIO_close(PL_parser->rsfp); - PL_parser->rsfp = NULL; + (void)PerlIO_close(PL_parser->rsfp); + PL_parser->rsfp = NULL; } if (PL_minus_F) { - Safefree(PL_splitstr); - PL_splitstr = NULL; + Safefree(PL_splitstr); + PL_splitstr = NULL; } /* switches */ @@ -1014,8 +1016,8 @@ perl_destruct(pTHXx) SvREFCNT_dec(PL_patchlevel); if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } PL_perldb = 0; @@ -1119,72 +1121,152 @@ perl_destruct(pTHXx) Safefree(PL_collation_name); PL_collation_name = NULL; #endif +#if defined(USE_PL_CURLOCALES) + for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) { + Safefree(PL_curlocales[i]); + PL_curlocales[i] = NULL; + } +#endif +#if defined(USE_POSIX_2008_LOCALE) && defined(USE_THREADS) + { + /* This also makes sure we aren't using a locale object that gets freed + * below */ + if ( PL_cur_locale_obj != NULL + && PL_cur_locale_obj != LC_GLOBAL_LOCALE + && PL_cur_locale_obj != PL_C_locale_obj + ) { + locale_t cur_locale = uselocale((locale_t) 0); + if (cur_locale == PL_cur_locale_obj) { + uselocale(LC_GLOBAL_LOCALE); + } + freelocale(PL_cur_locale_obj); + PL_cur_locale_obj = NULL; + } + } + +# ifdef USE_PL_CUR_LC_ALL + + if (PL_cur_LC_ALL) { + DEBUG_L( PerlIO_printf(Perl_debug_log, "PL_cur_LC_ALL=%p\n", PL_cur_LC_ALL)); + Safefree(PL_cur_LC_ALL); + PL_cur_LC_ALL = NULL; + } + +# endif + + if (PL_scratch_locale_obj) { + freelocale(PL_scratch_locale_obj); + PL_scratch_locale_obj = NULL; + } +#endif #ifdef USE_LOCALE_NUMERIC Safefree(PL_numeric_name); PL_numeric_name = NULL; SvREFCNT_dec(PL_numeric_radix_sv); PL_numeric_radix_sv = NULL; + SvREFCNT_dec(PL_underlying_radix_sv); + PL_underlying_radix_sv = NULL; +#endif +#ifdef USE_LOCALE_CTYPE + Safefree(PL_ctype_name); + PL_ctype_name = NULL; #endif - if (PL_langinfo_buf) { - Safefree(PL_langinfo_buf); - PL_langinfo_buf = NULL; + if (PL_setlocale_buf) { + Safefree(PL_setlocale_buf); + PL_setlocale_buf = NULL; } - /* clear character classes */ - for (i = 0; i < POSIX_SWASH_COUNT; i++) { - SvREFCNT_dec(PL_utf8_swash_ptrs[i]); - PL_utf8_swash_ptrs[i] = NULL; + SvREFCNT_dec(PL_langinfo_sv); + PL_langinfo_sv = NULL; + SvREFCNT_dec(PL_scratch_langinfo); + PL_scratch_langinfo = NULL; + +#if defined(USE_LOCALE_THREADS) && ! defined(USE_THREAD_SAFE_LOCALE) + if (PL_less_dicey_locale_buf) { + Safefree(PL_less_dicey_locale_buf); + PL_less_dicey_locale_buf = NULL; } - SvREFCNT_dec(PL_utf8_mark); +#endif + +#ifdef USE_LOCALE_CTYPE + SvREFCNT_dec(PL_warn_locale); + PL_warn_locale = NULL; +#endif + + SvREFCNT_dec(PL_AboveLatin1); + PL_AboveLatin1 = NULL; + SvREFCNT_dec(PL_Assigned_invlist); + PL_Assigned_invlist = NULL; + SvREFCNT_dec(PL_GCB_invlist); + PL_GCB_invlist = NULL; + SvREFCNT_dec(PL_HasMultiCharFold); + PL_HasMultiCharFold = NULL; + SvREFCNT_dec(PL_InMultiCharFold); + PL_InMultiCharFold = NULL; + SvREFCNT_dec(PL_Latin1); + PL_Latin1 = NULL; + SvREFCNT_dec(PL_LB_invlist); + PL_LB_invlist = NULL; + SvREFCNT_dec(PL_SB_invlist); + PL_SB_invlist = NULL; + SvREFCNT_dec(PL_SCX_invlist); + PL_SCX_invlist = NULL; + SvREFCNT_dec(PL_UpperLatin1); + PL_UpperLatin1 = NULL; + SvREFCNT_dec(PL_in_some_fold); + PL_in_some_fold = NULL; + SvREFCNT_dec(PL_utf8_foldclosures); + PL_utf8_foldclosures = NULL; + SvREFCNT_dec(PL_utf8_idcont); + PL_utf8_idcont = NULL; + SvREFCNT_dec(PL_utf8_idstart); + PL_utf8_idstart = NULL; + SvREFCNT_dec(PL_utf8_perl_idcont); + PL_utf8_perl_idcont = NULL; + SvREFCNT_dec(PL_utf8_perl_idstart); + PL_utf8_perl_idstart = NULL; + SvREFCNT_dec(PL_utf8_xidcont); + PL_utf8_xidcont = NULL; + SvREFCNT_dec(PL_utf8_xidstart); + PL_utf8_xidstart = NULL; + SvREFCNT_dec(PL_WB_invlist); + PL_WB_invlist = NULL; SvREFCNT_dec(PL_utf8_toupper); + PL_utf8_toupper = NULL; SvREFCNT_dec(PL_utf8_totitle); + PL_utf8_totitle = NULL; SvREFCNT_dec(PL_utf8_tolower); + PL_utf8_tolower = NULL; SvREFCNT_dec(PL_utf8_tofold); - SvREFCNT_dec(PL_utf8_idstart); - SvREFCNT_dec(PL_utf8_idcont); - SvREFCNT_dec(PL_utf8_foldable); - SvREFCNT_dec(PL_utf8_foldclosures); - SvREFCNT_dec(PL_AboveLatin1); + PL_utf8_tofold = NULL; + SvREFCNT_dec(PL_utf8_tosimplefold); + PL_utf8_tosimplefold = NULL; + SvREFCNT_dec(PL_utf8_charname_begin); + PL_utf8_charname_begin = NULL; + SvREFCNT_dec(PL_utf8_charname_continue); + PL_utf8_charname_continue = NULL; + SvREFCNT_dec(PL_utf8_mark); + PL_utf8_mark = NULL; SvREFCNT_dec(PL_InBitmap); - SvREFCNT_dec(PL_UpperLatin1); - SvREFCNT_dec(PL_Latin1); - SvREFCNT_dec(PL_NonL1NonFinalFold); - SvREFCNT_dec(PL_HasMultiCharFold); -#ifdef USE_LOCALE_CTYPE - SvREFCNT_dec(PL_warn_locale); -#endif - PL_utf8_mark = NULL; - PL_utf8_toupper = NULL; - PL_utf8_totitle = NULL; - PL_utf8_tolower = NULL; - PL_utf8_tofold = NULL; - PL_utf8_idstart = NULL; - PL_utf8_idcont = NULL; - PL_utf8_foldclosures = NULL; - PL_AboveLatin1 = NULL; - PL_InBitmap = NULL; - PL_HasMultiCharFold = NULL; -#ifdef USE_LOCALE_CTYPE - PL_warn_locale = NULL; -#endif - PL_Latin1 = NULL; - PL_NonL1NonFinalFold = NULL; - PL_UpperLatin1 = NULL; + PL_InBitmap = NULL; + SvREFCNT_dec(PL_CCC_non0_non230); + PL_CCC_non0_non230 = NULL; + SvREFCNT_dec(PL_Private_Use); + PL_Private_Use = NULL; + for (i = 0; i < POSIX_CC_COUNT; i++) { SvREFCNT_dec(PL_XPosix_ptrs[i]); PL_XPosix_ptrs[i] = NULL; + + if (i != CC_CASED_) { /* A copy of Alpha */ + SvREFCNT_dec(PL_Posix_ptrs[i]); + PL_Posix_ptrs[i] = NULL; + } } - PL_GCB_invlist = NULL; - PL_LB_invlist = NULL; - PL_SB_invlist = NULL; - PL_WB_invlist = NULL; - PL_Assigned_invlist = NULL; - if (!specialWARN(PL_compiling.cop_warnings)) - PerlMemShared_free(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = NULL; + free_and_set_cop_warnings(&PL_compiling, NULL); cophh_free(CopHINTHASH_get(&PL_compiling)); CopHINTHASH_set(&PL_compiling, cophh_new_empty()); CopFILE_free(&PL_compiling); @@ -1207,20 +1289,20 @@ perl_destruct(pTHXx) FREETMPS; if (destruct_level >= 2) { - if (PL_scopestack_ix != 0) - 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_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_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_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", - (long)cxstack_ix + 1); + if (PL_scopestack_ix != 0) + 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_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_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_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL),"Unbalanced context: %ld more PUSHes than POPs\n", + (long)cxstack_ix + 1); } #ifdef USE_ITHREADS @@ -1229,7 +1311,7 @@ perl_destruct(pTHXx) PL_regex_pad = NULL; #endif -#ifdef PERL_IMPLICIT_CONTEXT +#ifdef MULTIPLICITY /* the entries in this list are allocated via SV PVX's, so get freed * in sv_clean_all */ Safefree(PL_my_cxt_list); @@ -1239,7 +1321,7 @@ perl_destruct(pTHXx) /* the 2 is for PL_fdpid and PL_strtab */ while (sv_clean_all() > 2) - ; + ; #ifdef USE_ITHREADS Safefree(PL_stashpad); /* must come after sv_clean_all */ @@ -1261,36 +1343,36 @@ perl_destruct(pTHXx) /* Destruct the global string table. */ { - /* Yell and reset the HeVAL() slots that are still holding refcounts, - * so that sv_free() won't fail on them. - * Now that the global string table is using a single hunk of memory - * for both HE and HEK, we either need to explicitly unshare it the - * correct way, or actually free things here. - */ - I32 riter = 0; - const I32 max = HvMAX(PL_strtab); - HE * const * const array = HvARRAY(PL_strtab); - HE *hent = array[0]; - - for (;;) { - if (hent && ckWARN_d(WARN_INTERNAL)) { - HE * const next = HeNEXT(hent); - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Unbalanced string table refcount: (%ld) for \"%s\"", - (long)hent->he_valu.hent_refcount, HeKEY(hent)); - Safefree(hent); - hent = next; - } - if (!hent) { - if (++riter > max) - break; - hent = array[riter]; - } - } - - Safefree(array); - HvARRAY(PL_strtab) = 0; - HvTOTALKEYS(PL_strtab) = 0; + /* Yell and reset the HeVAL() slots that are still holding refcounts, + * so that sv_free() won't fail on them. + * Now that the global string table is using a single hunk of memory + * for both HE and HEK, we either need to explicitly unshare it the + * correct way, or actually free things here. + */ + I32 riter = 0; + const I32 max = HvMAX(PL_strtab); + HE * const * const array = HvARRAY(PL_strtab); + HE *hent = array[0]; + + for (;;) { + if (hent && ckWARN_d(WARN_INTERNAL)) { + HE * const next = HeNEXT(hent); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "Unbalanced string table refcount: (%ld) for \"%s\"", + (long)hent->he_valu.hent_refcount, HeKEY(hent)); + Safefree(hent); + hent = next; + } + if (!hent) { + if (++riter > max) + break; + hent = array[riter]; + } + } + + Safefree(array); + HvARRAY(PL_strtab) = 0; + HvTOTALKEYS(PL_strtab) = 0; } SvREFCNT_dec(PL_strtab); @@ -1328,62 +1410,62 @@ perl_destruct(pTHXx) } if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Scalars leaked: %ld\n", (long)PL_sv_count); #ifdef DEBUG_LEAKING_SCALARS if (PL_sv_count != 0) { - SV* sva; - SV* sv; - SV* svend; - - 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) != (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 (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)", - sv->sv_debug_line, - sv->sv_debug_inpad ? "for" : "by", - sv->sv_debug_optype ? - PL_op_name[sv->sv_debug_optype]: "(none)", - PTR2UV(sv->sv_debug_parent), - sv->sv_debug_serial - ); + SV* sva; + SV* sv; + SV* svend; + + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { + svend = &sva[SvREFCNT(sva)]; + for (sv = sva + 1; sv < svend; ++sv) { + if (!SvIS_FREED(sv)) { + PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p" + " flags=0x%" UVxf + " refcnt=%" UVuf pTHX__FORMAT "\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)", + sv->sv_debug_line, + sv->sv_debug_inpad ? "for" : "by", + sv->sv_debug_optype ? + PL_op_name[sv->sv_debug_optype]: "(none)", + PTR2UV(sv->sv_debug_parent), + sv->sv_debug_serial + ); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP - Perl_dump_sv_child(aTHX_ sv); + Perl_dump_sv_child(aTHX_ sv); #endif - } - } - } + } + } + } } #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP { - int status; - fd_set rset; - /* Wait for up to 4 seconds for child to terminate. - This seems to be the least effort way of timing out on reaping - its exit status. */ - struct timeval waitfor = {4, 0}; - int sock = PL_dumper_fd; - - shutdown(sock, 1); - FD_ZERO(&rset); - FD_SET(sock, &rset); - select(sock + 1, &rset, NULL, NULL, &waitfor); - waitpid(child, &status, WNOHANG); - close(sock); + int status; + fd_set rset; + /* Wait for up to 4 seconds for child to terminate. + This seems to be the least effort way of timing out on reaping + its exit status. */ + struct timeval waitfor = {4, 0}; + int sock = PL_dumper_fd; + + shutdown(sock, 1); + FD_ZERO(&rset); + FD_SET(sock, &rset); + select(sock + 1, &rset, NULL, NULL, &waitfor); + waitpid(child, &status, WNOHANG); + close(sock); } #endif #endif #ifdef DEBUG_LEAKING_SCALARS_ABORT if (PL_sv_count) - abort(); + abort(); #endif PL_sv_count = 0; @@ -1408,11 +1490,11 @@ perl_destruct(pTHXx) PL_psig_name = (SV**)NULL; PL_psig_ptr = (SV**)NULL; { - /* We need to NULL PL_psig_pend first, so that - signal handlers know not to use it */ - int *psig_save = PL_psig_pend; - PL_psig_pend = (int*)NULL; - Safefree(psig_save); + /* We need to NULL PL_psig_pend first, so that + signal handlers know not to use it */ + int *psig_save = PL_psig_pend; + PL_psig_pend = (int*)NULL; + Safefree(psig_save); } nuke_stacks(); TAINTING_set(FALSE); @@ -1437,32 +1519,32 @@ perl_destruct(pTHXx) sv_free_arenas(); while (PL_regmatch_slab) { - regmatch_slab *s = PL_regmatch_slab; - PL_regmatch_slab = PL_regmatch_slab->next; - Safefree(s); + regmatch_slab *s = PL_regmatch_slab; + PL_regmatch_slab = PL_regmatch_slab->next; + Safefree(s); } /* As the absolutely last thing, free the non-arena SV for mess() */ if (PL_mess_sv) { - /* we know that type == SVt_PVMG */ - - /* it could have accumulated taint magic */ - MAGIC* mg; - MAGIC* moremagic; - for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { - moremagic = mg->mg_moremagic; - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global - && mg->mg_len >= 0) - Safefree(mg->mg_ptr); - Safefree(mg); - } - - /* we know that type >= SVt_PV */ - SvPV_free(PL_mess_sv); - Safefree(SvANY(PL_mess_sv)); - Safefree(PL_mess_sv); - PL_mess_sv = NULL; + /* we know that type == SVt_PVMG */ + + /* it could have accumulated taint magic */ + MAGIC* mg; + MAGIC* moremagic; + for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) { + moremagic = mg->mg_moremagic; + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global + && mg->mg_len >= 0) + Safefree(mg->mg_ptr); + Safefree(mg); + } + + /* we know that type >= SVt_PV */ + SvPV_free(PL_mess_sv); + Safefree(SvANY(PL_mess_sv)); + Safefree(PL_mess_sv); + PL_mess_sv = NULL; } return STATUS_EXIT; } @@ -1478,50 +1560,43 @@ Releases a Perl interpreter. See L. void perl_free(pTHXx) { - dVAR; PERL_ARGS_ASSERT_PERL_FREE; if (PL_veto_cleanup) - return; + return; #ifdef PERL_TRACK_MEMPOOL { - /* - * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero - * value as we're probably hunting memory leaks then - */ - if (PL_perl_destruct_level == 0) { - const U32 old_debug = PL_debug; - /* Emulate the PerlHost behaviour of free()ing all memory allocated in this - thread at thread exit. */ - if (DEBUG_m_TEST) { - PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " - "free this thread's memory\n"); - PL_debug &= ~ DEBUG_m_FLAG; - } - while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ - char * next = (char *)(aTHXx->Imemory_debug_header.next); - Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; - safesysfree(ptr); - } - PL_debug = old_debug; - } - } -#endif - -#if defined(WIN32) || defined(NETWARE) + /* + * Don't free thread memory if PERL_DESTRUCT_LEVEL is set to a non-zero + * value as we're probably hunting memory leaks then + */ + if (PL_perl_destruct_level == 0) { + const U32 old_debug = PL_debug; + /* Emulate the PerlHost behaviour of free()ing all memory allocated in this + thread at thread exit. */ + if (DEBUG_m_TEST) { + PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " + "free this thread's memory\n"); + PL_debug &= ~ DEBUG_m_FLAG; + } + while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)){ + char * next = (char *)(aTHXx->Imemory_debug_header.next); + Malloc_t ptr = PERL_MEMORY_DEBUG_HEADER_SIZE + next; + safesysfree(ptr); + } + PL_debug = old_debug; + } + } +#endif + +#if defined(WIN32) # if defined(PERL_IMPLICIT_SYS) { -# ifdef NETWARE - void *host = nw_internal_host; - PerlMem_free(aTHXx); - nw_delete_internal_host(host); -# else void *host = w32_internal_host; PerlMem_free(aTHXx); win32_delete_internal_host(host); -# endif } # else PerlMem_free(aTHXx); @@ -1547,18 +1622,27 @@ __attribute__((destructor)) #endif perl_fini(void) { - dVAR; if ( -#ifdef PERL_GLOBAL_STRUCT_PRIVATE - my_vars && -#endif PL_curinterp && !PL_veto_cleanup) - FREE_THREAD_KEY; + FREE_THREAD_KEY; } #endif /* WIN32 */ #endif /* THREADS */ +/* +=for apidoc call_atexit + +Add a function C to the list of functions to be called at global +destruction. C will be passed as an argument to C; it can point to a +C so that you can pass anything you want. + +Note that under threads, C may run multiple times. This is because the +list is executed each time the current or any descendent thread terminates. + +=cut +*/ + void Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) { @@ -1568,24 +1652,114 @@ Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr) ++PL_exitlistlen; } +#ifdef USE_ENVIRON_ARRAY +static void +dup_environ(pTHX) +{ +# ifdef USE_ITHREADS + if (aTHX != PL_curinterp) + return; +# endif + if (!environ) + return; + + size_t n_entries = 0, vars_size = 0; + + for (char **ep = environ; *ep; ++ep) { + ++n_entries; + vars_size += strlen(*ep) + 1; + } + + /* To save memory, we store both the environ array and its values in a + * single memory block. */ + char **new_environ = (char**)PerlMemShared_malloc( + (sizeof(char*) * (n_entries + 1)) + vars_size + ); + char *vars = (char*)(new_environ + n_entries + 1); + + for (size_t i = 0, copied = 0; n_entries > i; ++i) { + size_t len = strlen(environ[i]) + 1; + new_environ[i] = (char *) CopyD(environ[i], vars + copied, len, char); + copied += len; + } + new_environ[n_entries] = NULL; + + environ = new_environ; + /* Store a pointer in a global variable to ensure it's always reachable so + * LeakSanitizer/Valgrind won't complain about it. We can't ever free it. + * Even if libc allocates a new environ, it's possible that some of its + * values will still be pointing to the old environ. + */ + PL_my_environ = new_environ; +} +#endif + /* =for apidoc perl_parse -Tells a Perl interpreter to parse a Perl script. See L. +Tells a Perl interpreter to parse a Perl script. This performs most +of the initialisation of a Perl interpreter. See L for +a tutorial. + +C points to the Perl interpreter that is to parse the script. +It must have been previously created through the use of L +and L. C points to a callback function that +will be called to set up the ability for this Perl interpreter to load +XS extensions, or may be null to perform no such setup. + +C and C supply a set of command-line arguments to the Perl +interpreter, as would normally be passed to the C
function of +a C program. C must be null. These arguments are where +the script to parse is specified, either by naming a script file or by +providing a script in a C<-e> option. +If L|perlvar/$0> will be written to in the Perl interpreter, then +the argument strings must be in writable memory, and so mustn't just be +string constants. + +C specifies a set of environment variables that will be used by +this Perl interpreter. If non-null, it must point to a null-terminated +array of environment strings. If null, the Perl interpreter will use +the environment supplied by the C global variable. + +This function initialises the interpreter, and parses and compiles the +script specified by the command-line arguments. This includes executing +code in C, C, and C blocks. It does not execute +C blocks or the main program. + +Returns an integer of slightly tricky interpretation. The correct +use of the return value is as a truth value indicating whether there +was a failure in initialisation. If zero is returned, this indicates +that initialisation was successful, and it is safe to proceed to call +L and make other use of it. If a non-zero value is returned, +this indicates some problem that means the interpreter wants to terminate. +The interpreter should not be just abandoned upon such failure; the caller +should proceed to shut the interpreter down cleanly with L +and free it with L. + +For historical reasons, the non-zero return value also attempts to +be a suitable value to pass to the C library function C (or to +return from C
), to serve as an exit code indicating the nature +of the way initialisation terminated. However, this isn't portable, +due to differing exit code conventions. An attempt is made to return +an exit code of the type required by the host operating system, but +because it is constrained to be non-zero, it is not necessarily possible +to indicate every type of exit. It is only reliable on Unix, where a +zero exit code can be augmented with a set bit that will be ignored. +In any case, this function is not the correct place to acquire an exit +code: one should get that from L. =cut */ #define SET_CURSTASH(newstash) \ - if (PL_curstash != newstash) { \ - SvREFCNT_dec(PL_curstash); \ - PL_curstash = (HV *)SvREFCNT_inc(newstash); \ - } + if (PL_curstash != newstash) { \ + SvREFCNT_dec(PL_curstash); \ + PL_curstash = (HV *)SvREFCNT_inc(newstash); \ + } int perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) { - dVAR; I32 oldscope; int ret; dJMPENV; @@ -1594,147 +1768,136 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) #ifndef MULTIPLICITY PERL_UNUSED_ARG(my_perl); #endif -#if (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_DEBUG)) && !defined(NO_PERL_HASH_SEED_DEBUG) - { - const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); - - if (s && strEQ(s, "1")) { - const unsigned char *seed= PERL_HASH_SEED; - const unsigned char *seed_end= PERL_HASH_SEED + PERL_HASH_SEED_BYTES; - PerlIO_printf(Perl_debug_log, "HASH_FUNCTION = %s HASH_SEED = 0x", PERL_HASH_FUNC); - while (seed < seed_end) { - PerlIO_printf(Perl_debug_log, "%02x", *seed++); - } -#ifdef PERL_HASH_RANDOMIZE_KEYS - PerlIO_printf(Perl_debug_log, " PERTURB_KEYS = %d (%s)", - PL_HASH_RAND_BITS_ENABLED, - PL_HASH_RAND_BITS_ENABLED == 0 ? "NO" : PL_HASH_RAND_BITS_ENABLED == 1 ? "RANDOM" : "DETERMINISTIC"); -#endif - PerlIO_printf(Perl_debug_log, "\n"); - } - } -#endif /* #if (defined(USE_HASH_SEED) ... */ - + debug_hash_seed(false); #ifdef __amigaos4__ { struct NameTranslationInfo nti; - __translate_amiga_to_unix_path_name(&argv[0],&nti); + __translate_amiga_to_unix_path_name(&argv[0],&nti); } #endif + { + int i; + assert(argc >= 0); + for(i = 0; i != argc; i++) + assert(argv[i]); + assert(!argv[argc]); + } PL_origargc = argc; PL_origargv = argv; if (PL_origalen != 0) { - PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ + PL_origalen = 1; /* don't use old PL_origalen if perl_parse() is called again */ } else { - /* Set PL_origalen be the sum of the contiguous argv[] - * elements plus the size of the env in case that it is - * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() - * as the maximum modifiable length of $0. In the worst case - * the area we are able to modify is limited to the size of - * the original argv[0]. (See below for 'contiguous', though.) - * --jhi */ - const char *s = NULL; - const UV mask = ~(UV)(PTRSIZE-1); + /* Set PL_origalen be the sum of the contiguous argv[] + * elements plus the size of the env in case that it is + * contiguous with the argv[]. This is used in mg.c:Perl_magic_set() + * as the maximum modifiable length of $0. In the worst case + * the area we are able to modify is limited to the size of + * the original argv[0]. (See below for 'contiguous', though.) + * --jhi */ + const char *s = NULL; + const UV mask = ~(UV)(PTRSIZE-1); /* Do the mask check only if the args seem like aligned. */ - const UV aligned = - (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); - - /* See if all the arguments are contiguous in memory. Note - * that 'contiguous' is a loose term because some platforms - * align the argv[] and the envp[]. If the arguments look - * like non-aligned, assume that they are 'strictly' or - * 'traditionally' contiguous. If the arguments look like - * aligned, we just check that they are within aligned - * PTRSIZE bytes. As long as no system has something bizarre - * like the argv[] interleaved with some other data, we are - * fine. (Did I just evoke Murphy's Law?) --jhi */ - if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { + const UV aligned = + (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); + + /* See if all the arguments are contiguous in memory. Note + * that 'contiguous' is a loose term because some platforms + * align the argv[] and the envp[]. If the arguments look + * like non-aligned, assume that they are 'strictly' or + * 'traditionally' contiguous. If the arguments look like + * aligned, we just check that they are within aligned + * PTRSIZE bytes. As long as no system has something bizarre + * like the argv[] interleaved with some other data, we are + * fine. (Did I just evoke Murphy's Law?) --jhi */ + if (PL_origargv && PL_origargc >= 1 && (s = PL_origargv[0])) { int i; - while (*s) s++; - for (i = 1; i < PL_origargc; i++) { - if ((PL_origargv[i] == s + 1 + while (*s) s++; + for (i = 1; i < PL_origargc; i++) { + if ((PL_origargv[i] == s + 1 #ifdef OS2 - || PL_origargv[i] == s + 2 -#endif - ) - || - (aligned && - (PL_origargv[i] > s && - PL_origargv[i] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { - s = PL_origargv[i]; - while (*s) s++; - } - else - break; - } - } - -#ifndef PERL_USE_SAFE_PUTENV - /* Can we grab env area too to be used as the area for $0? */ - if (s && PL_origenviron && !PL_use_safe_putenv) { - if ((PL_origenviron[0] == s + 1) - || - (aligned && - (PL_origenviron[0] > s && - PL_origenviron[0] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { + || PL_origargv[i] == s + 2 +#endif + ) + || + (aligned && + (PL_origargv[i] > s && + PL_origargv[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origargv[i]; + while (*s) s++; + } + else + break; + } + } + +#ifdef USE_ENVIRON_ARRAY + /* Can we grab env area too to be used as the area for $0? */ + if (s && PL_origenviron) { + if ((PL_origenviron[0] == s + 1) + || + (aligned && + (PL_origenviron[0] > s && + PL_origenviron[0] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { int i; #ifndef OS2 /* ENVIRON is read by the kernel too. */ - s = PL_origenviron[0]; - while (*s) s++; -#endif - my_setenv("NoNe SuCh", NULL); - /* Force copy of environment. */ - for (i = 1; PL_origenviron[i]; i++) { - if (PL_origenviron[i] == s + 1 - || - (aligned && - (PL_origenviron[i] > s && - PL_origenviron[i] <= - INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) - ) - { - s = PL_origenviron[i]; - while (*s) s++; - } - else - break; - } - } - } -#endif /* !defined(PERL_USE_SAFE_PUTENV) */ - - PL_origalen = s ? s - PL_origargv[0] + 1 : 0; + s = PL_origenviron[0]; + while (*s) s++; +#endif + + /* Force copy of environment. */ + if (PL_origenviron == environ) + dup_environ(aTHX); + + for (i = 1; PL_origenviron[i]; i++) { + if (PL_origenviron[i] == s + 1 + || + (aligned && + (PL_origenviron[i] > s && + PL_origenviron[i] <= + INT2PTR(char *, PTR2UV(s + PTRSIZE) & mask))) + ) + { + s = PL_origenviron[i]; + while (*s) s++; + } + else + break; + } + } + } +#endif /* USE_ENVIRON_ARRAY */ + + PL_origalen = s ? s - PL_origargv[0] + 1 : 0; } if (PL_do_undump) { - /* Come here if running an undumped a.out. */ - - PL_origfilename = savepv(argv[0]); - PL_do_undump = FALSE; - cxstack_ix = -1; /* start label stack again */ - init_ids(); - assert (!TAINT_get); - TAINT; - set_caret_X(); - TAINT_NOT; - init_postdump_symbols(argc,argv,env); - return 0; + /* Come here if running an undumped a.out. */ + + PL_origfilename = savepv(argv[0]); + PL_do_undump = FALSE; + cxstack_ix = -1; /* start label stack again */ + init_ids(); + assert (!TAINT_get); + TAINT; + set_caret_X(); + TAINT_NOT; + init_postdump_symbols(argc,argv,env); + return 0; } - if (PL_main_root) { - op_free(PL_main_root); - PL_main_root = NULL; - } + op_free(PL_main_root); + PL_main_root = NULL; + PL_main_start = NULL; SvREFCNT_dec(PL_main_cv); PL_main_cv = NULL; @@ -1746,38 +1909,46 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) JMPENV_PUSH(ret); switch (ret) { case 0: - parse_body(env,xsinit); - if (PL_unitcheckav) { - call_list(oldscope, PL_unitcheckav); - } - if (PL_checkav) { - PERL_SET_PHASE(PERL_PHASE_CHECK); - call_list(oldscope, PL_checkav); - } - ret = 0; - break; + parse_body(env,xsinit); + if (PL_unitcheckav) { + call_list(oldscope, PL_unitcheckav); + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); + call_list(oldscope, PL_checkav); + } + ret = 0; + break; case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ case 2: - /* my_exit() was called */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - if (PL_unitcheckav) { - call_list(oldscope, PL_unitcheckav); - } - if (PL_checkav) { - PERL_SET_PHASE(PERL_PHASE_CHECK); - call_list(oldscope, PL_checkav); - } - ret = STATUS_EXIT; - break; + /* my_exit() was called */ + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + if (PL_unitcheckav) { + call_list(oldscope, PL_unitcheckav); + } + if (PL_checkav) { + PERL_SET_PHASE(PERL_PHASE_CHECK); + call_list(oldscope, PL_checkav); + } + ret = STATUS_EXIT; + if (ret == 0) { + /* + * We do this here to avoid [perl #2754]. + * Note this may cause trouble with Module::Install. + * See: [perl #132577]. + */ + ret = 0x100; + } + break; case 3: - PerlIO_printf(Perl_error_log, "panic: top_env\n"); - ret = 1; - break; + PerlIO_printf(Perl_error_log, "panic: top_env\n"); + ret = 1; + break; } JMPENV_POP; return ret; @@ -1788,6 +1959,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) /* What this returns is subject to change. Use the public interface in Config. */ + static void S_Internals_V(pTHX_ CV *cv) { @@ -1799,130 +1971,126 @@ S_Internals_V(pTHX_ CV *cv) #endif const int entries = 3 + local_patch_count; int i; - static const char non_bincompat_options[] = + /* NOTE - This list must remain sorted. Do not put any settings here + * which affect binary compatibility */ + static const char non_bincompat_options[] = # ifdef DEBUGGING - " DEBUGGING" + " DEBUGGING" +# endif +# ifdef HAS_LONG_DOUBLE + " HAS_LONG_DOUBLE" +# endif +# ifdef HAS_STRTOLD + " HAS_STRTOLD" # endif # ifdef NO_MATHOMS - " NO_MATHOMS" + " NO_MATHOMS" # endif -# ifdef NO_HASH_SEED - " NO_HASH_SEED" +# ifdef NO_PERL_INTERNAL_RAND_SEED + " NO_PERL_INTERNAL_RAND_SEED" # endif -# ifdef NO_TAINT_SUPPORT - " NO_TAINT_SUPPORT" +# ifdef NO_PERL_RAND_SEED + " NO_PERL_RAND_SEED" # endif -# ifdef PERL_BOOL_AS_CHAR - " PERL_BOOL_AS_CHAR" +# ifdef NO_TAINT_SUPPORT + " NO_TAINT_SUPPORT" # endif # ifdef PERL_COPY_ON_WRITE - " PERL_COPY_ON_WRITE" + " PERL_COPY_ON_WRITE" # endif # ifdef PERL_DISABLE_PMC - " PERL_DISABLE_PMC" + " PERL_DISABLE_PMC" # endif # ifdef PERL_DONT_CREATE_GVSV - " PERL_DONT_CREATE_GVSV" + " PERL_DONT_CREATE_GVSV" # endif # ifdef PERL_EXTERNAL_GLOB - " PERL_EXTERNAL_GLOB" -# endif -# ifdef PERL_HASH_FUNC_SIPHASH - " PERL_HASH_FUNC_SIPHASH" -# endif -# ifdef PERL_HASH_FUNC_SDBM - " PERL_HASH_FUNC_SDBM" -# endif -# ifdef PERL_HASH_FUNC_DJB2 - " PERL_HASH_FUNC_DJB2" -# endif -# ifdef PERL_HASH_FUNC_SUPERFAST - " PERL_HASH_FUNC_SUPERFAST" -# endif -# ifdef PERL_HASH_FUNC_MURMUR3 - " PERL_HASH_FUNC_MURMUR3" -# endif -# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME - " PERL_HASH_FUNC_ONE_AT_A_TIME" -# endif -# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_HARD - " PERL_HASH_FUNC_ONE_AT_A_TIME_HARD" -# endif -# ifdef PERL_HASH_FUNC_ONE_AT_A_TIME_OLD - " PERL_HASH_FUNC_ONE_AT_A_TIME_OLD" + " PERL_EXTERNAL_GLOB" # endif # ifdef PERL_IS_MINIPERL - " PERL_IS_MINIPERL" + " PERL_IS_MINIPERL" # endif # ifdef PERL_MALLOC_WRAP - " PERL_MALLOC_WRAP" + " PERL_MALLOC_WRAP" # endif # ifdef PERL_MEM_LOG - " PERL_MEM_LOG" + " PERL_MEM_LOG" # endif # ifdef PERL_MEM_LOG_NOIMPL - " PERL_MEM_LOG_NOIMPL" + " PERL_MEM_LOG_NOIMPL" # endif # ifdef PERL_OP_PARENT - " PERL_OP_PARENT" + " PERL_OP_PARENT" # endif # ifdef PERL_PERTURB_KEYS_DETERMINISTIC - " PERL_PERTURB_KEYS_DETERMINISTIC" + " PERL_PERTURB_KEYS_DETERMINISTIC" # endif # ifdef PERL_PERTURB_KEYS_DISABLED - " PERL_PERTURB_KEYS_DISABLED" + " PERL_PERTURB_KEYS_DISABLED" # endif # ifdef PERL_PERTURB_KEYS_RANDOM - " PERL_PERTURB_KEYS_RANDOM" + " PERL_PERTURB_KEYS_RANDOM" # endif # ifdef PERL_PRESERVE_IVUV - " PERL_PRESERVE_IVUV" + " PERL_PRESERVE_IVUV" +# endif +# ifdef PERL_RC_STACK + " PERL_RC_STACK" # endif # ifdef PERL_RELOCATABLE_INCPUSH - " PERL_RELOCATABLE_INCPUSH" + " PERL_RELOCATABLE_INCPUSH" # endif # ifdef PERL_USE_DEVEL - " PERL_USE_DEVEL" + " PERL_USE_DEVEL" # endif # ifdef PERL_USE_SAFE_PUTENV - " PERL_USE_SAFE_PUTENV" + " PERL_USE_SAFE_PUTENV" +# endif + +# ifdef PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES + " PERL_USE_UNSHARED_KEYS_IN_LARGE_HASHES" # endif # ifdef SILENT_NO_TAINT_SUPPORT " SILENT_NO_TAINT_SUPPORT" # endif # ifdef UNLINK_ALL_VERSIONS - " UNLINK_ALL_VERSIONS" + " UNLINK_ALL_VERSIONS" # endif # ifdef USE_ATTRIBUTES_FOR_PERLIO - " USE_ATTRIBUTES_FOR_PERLIO" + " USE_ATTRIBUTES_FOR_PERLIO" # endif # ifdef USE_FAST_STDIO - " USE_FAST_STDIO" -# endif + " USE_FAST_STDIO" +# endif # ifdef USE_LOCALE - " USE_LOCALE" + " USE_LOCALE" # endif # ifdef USE_LOCALE_CTYPE - " USE_LOCALE_CTYPE" + " USE_LOCALE_CTYPE" # endif # ifdef WIN32_NO_REGISTRY - " USE_NO_REGISTRY" + " USE_NO_REGISTRY" # endif # ifdef USE_PERL_ATOF - " USE_PERL_ATOF" -# endif + " USE_PERL_ATOF" +# endif # ifdef USE_SITECUSTOMIZE - " USE_SITECUSTOMIZE" -# endif - ; + " USE_SITECUSTOMIZE" +# endif +# ifdef USE_THREAD_SAFE_LOCALE + " USE_THREAD_SAFE_LOCALE" +# endif + ""; /* keep this on a line by itself, WITH the empty string */ + PERL_UNUSED_ARG(cv); PERL_UNUSED_VAR(items); EXTEND(SP, entries); - PUSHs(sv_2mortal(newSVpv(PL_bincompat_options, 0))); + PUSHs(newSVpvn_flags(PL_bincompat_options, strlen(PL_bincompat_options), + SVs_TEMP)); PUSHs(Perl_newSVpvn_flags(aTHX_ non_bincompat_options, - sizeof(non_bincompat_options) - 1, SVs_TEMP)); + sizeof(non_bincompat_options) - 1, SVs_TEMP)); #ifndef PERL_BUILD_DATE # ifdef __DATE__ @@ -1936,15 +2104,17 @@ S_Internals_V(pTHX_ CV *cv) #ifdef PERL_BUILD_DATE PUSHs(Perl_newSVpvn_flags(aTHX_ - STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), - SVs_TEMP)); + STR_WITH_LEN("Compiled at " PERL_BUILD_DATE), + SVs_TEMP)); #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))); + /* This will be an undef, if PL_localpatches[i] is NULL. */ + PUSHs(newSVpvn_flags(PL_localpatches[i], + PL_localpatches[i] == NULL ? 0 : strlen(PL_localpatches[i]), + SVs_TEMP)); } XSRETURN(entries); @@ -1962,7 +2132,6 @@ S_Internals_V(pTHX_ CV *cv) STATIC void * S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { - dVAR; PerlIO *rsfp; int argc = PL_origargc; char **argv = PL_origargv; @@ -1971,6 +2140,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) char c; bool doextract = FALSE; const char *cddir = NULL; + bool minus_e = FALSE; /* both -e and -E */ #ifdef USE_SITECUSTOMIZE bool minus_f = FALSE; #endif @@ -1983,234 +2153,233 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) init_main_stash(); { - const char *s; + const char *s; for (argc--,argv++; argc > 0; argc--,argv++) { - if (argv[0][0] != '-' || !argv[0][1]) - break; - s = argv[0]+1; + if (argv[0][0] != '-' || !argv[0][1]) + break; + s = argv[0]+1; reswitch: - switch ((c = *s)) { - case 'C': + switch ((c = *s)) { + case 'C': #ifndef PERL_STRICT_CR - case '\r': -#endif - case ' ': - case '0': - case 'F': - case 'a': - case 'c': - case 'd': - case 'D': - case 'h': - case 'i': - case 'l': - case 'M': - case 'm': - case 'n': - case 'p': - case 's': - case 'u': - case 'U': - case 'v': - case 'W': - case 'X': - case 'w': - if ((s = moreswitches(s))) - goto reswitch; - break; - - case 't': + case '\r': +#endif + case ' ': + case '0': + case 'F': + case 'a': + case 'c': + case 'd': + case 'D': + case 'g': + case '?': + case 'h': + case 'i': + case 'l': + case 'M': + case 'm': + case 'n': + case 'p': + case 's': + case 'u': + case 'U': + case 'v': + case 'W': + case 'X': + case 'w': + if ((s = moreswitches(s))) + goto reswitch; + break; + + case 't': #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('t'); - if( !TAINTING_get ) { - TAINT_WARN_set(TRUE); - TAINTING_set(TRUE); - } -#endif - s++; - goto reswitch; - case 'T': + CHECK_MALLOC_TOO_LATE_FOR('t'); + if( !TAINTING_get ) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); + } +#endif + s++; + goto reswitch; + case 'T': #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('T'); - TAINTING_set(TRUE); - TAINT_WARN_set(FALSE); -#endif - s++; - goto reswitch; - - case 'E': - PL_minus_E = TRUE; - /* FALLTHROUGH */ - case 'e': - forbid_setid('e', FALSE); - if (!PL_e_script) { - PL_e_script = newSVpvs(""); - add_read_e_script = TRUE; - } - if (*++s) - sv_catpv(PL_e_script, s); - else if (argv[1]) { - sv_catpv(PL_e_script, argv[1]); - argc--,argv++; - } - else - Perl_croak(aTHX_ "No code specified for -%c", c); - sv_catpvs(PL_e_script, "\n"); - break; - - case 'f': + CHECK_MALLOC_TOO_LATE_FOR('T'); + TAINTING_set(TRUE); + TAINT_WARN_set(FALSE); +#endif + s++; + goto reswitch; + + case 'E': + PL_minus_E = TRUE; + /* FALLTHROUGH */ + case 'e': + forbid_setid('e', FALSE); + minus_e = TRUE; + if (!PL_e_script) { + PL_e_script = newSVpvs(""); + add_read_e_script = TRUE; + } + if (*++s) + sv_catpv(PL_e_script, s); + else if (argv[1]) { + sv_catpv(PL_e_script, argv[1]); + argc--,argv++; + } + else + Perl_croak(aTHX_ "No code specified for -%c", c); + sv_catpvs(PL_e_script, "\n"); + break; + + case 'f': #ifdef USE_SITECUSTOMIZE - minus_f = TRUE; -#endif - s++; - goto reswitch; - - case 'I': /* -I handled both here and in moreswitches() */ - forbid_setid('I', FALSE); - if (!*++s && (s=argv[1]) != NULL) { - argc--,argv++; - } - if (s && *s) { - STRLEN len = strlen(s); - incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); - } - else - Perl_croak(aTHX_ "No directory specified for -I"); - break; - case 'S': - forbid_setid('S', FALSE); - dosearch = TRUE; - s++; - goto reswitch; - case 'V': - { - SV *opts_prog; - - if (*++s != ':') { - opts_prog = newSVpvs("use Config; Config::_V()"); - } - else { - ++s; - opts_prog = Perl_newSVpvf(aTHX_ - "use Config; Config::config_vars(qw%c%s%c)", - 0, s, 0); - s += strlen(s); - } - 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': - doextract = TRUE; - s++; - if (*s) - cddir = s; - break; - case 0: - break; - case '-': - if (!*++s || isSPACE(*s)) { - argc--,argv++; - goto switch_end; - } - /* catch use of gnu style long options. - Both of these exit immediately. */ - if (strEQ(s, "version")) - minus_v(); - if (strEQ(s, "help")) - usage(); - s--; - /* FALLTHROUGH */ - default: - Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); - } + minus_f = TRUE; +#endif + s++; + goto reswitch; + + case 'I': /* -I handled both here and in moreswitches() */ + forbid_setid('I', FALSE); + if (!*++s && (s=argv[1]) != NULL) { + argc--,argv++; + } + if (s && *s) { + STRLEN len = strlen(s); + incpush(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS); + } + else + Perl_croak(aTHX_ "No directory specified for -I"); + break; + case 'S': + forbid_setid('S', FALSE); + dosearch = TRUE; + s++; + goto reswitch; + case 'V': + { + SV *opts_prog; + + if (*++s != ':') { + opts_prog = newSVpvs("use Config; Config::_V()"); + } + else { + ++s; + opts_prog = Perl_newSVpvf(aTHX_ + "use Config; Config::config_vars(qw%c%s%c)", + 0, s, 0); + s += strlen(s); + } + 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': + doextract = TRUE; + s++; + if (*s) + cddir = s; + break; + case 0: + break; + case '-': + if (!*++s || isSPACE(*s)) { + argc--,argv++; + goto switch_end; + } + /* catch use of gnu style long options. + Both of these exit immediately. */ + if (strEQ(s, "version")) + minus_v(); + if (strEQ(s, "help")) + usage(); + s--; + /* FALLTHROUGH */ + default: + Perl_croak(aTHX_ "Unrecognized switch: -%s (-h will show valid options)",s); + } } } switch_end: { - char *s; + char *s; if ( #ifndef SECURE_INTERNAL_GETENV !TAINTING_get && #endif - (s = PerlEnv_getenv("PERL5OPT"))) + (s = PerlEnv_getenv("PERL5OPT"))) { - /* s points to static memory in getenv(), which may be overwritten at - * any time; use a mortal copy instead */ - s = SvPVX(sv_2mortal(newSVpv(s, 0))); - - while (isSPACE(*s)) - s++; - if (*s == '-' && *(s+1) == 'T') { + while (isSPACE(*s)) + s++; + if (*s == '-' && *(s+1) == 'T') { #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - CHECK_MALLOC_TOO_LATE_FOR('T'); - TAINTING_set(TRUE); + CHECK_MALLOC_TOO_LATE_FOR('T'); + TAINTING_set(TRUE); TAINT_WARN_set(FALSE); #endif - } - else { - char *popt_copy = NULL; - while (s && *s) { - const char *d; - while (isSPACE(*s)) - s++; - if (*s == '-') { - s++; - if (isSPACE(*s)) - continue; - } - d = s; - if (!*s) - break; - if (!strchr("CDIMUdmtwW", *s)) - Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); - while (++s && *s) { - if (isSPACE(*s)) { - if (!popt_copy) { - popt_copy = SvPVX(sv_2mortal(newSVpv(d,0))); - s = popt_copy + (s - d); - d = popt_copy; - } - *s++ = '\0'; - break; - } - } - if (*d == 't') { + } + else { + char *popt_copy = NULL; + while (s && *s) { + const char *d; + while (isSPACE(*s)) + s++; + if (*s == '-') { + s++; + if (isSPACE(*s)) + continue; + } + d = s; + if (!*s) + break; + if (!memCHRs("CDIMUdmtwW", *s)) + Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s); + while (++s && *s) { + if (isSPACE(*s)) { + if (!popt_copy) { + popt_copy = SvPVX(newSVpvn_flags(d, strlen(d), SVs_TEMP)); + s = popt_copy + (s - d); + d = popt_copy; + } + *s++ = '\0'; + break; + } + } + if (*d == 't') { #if defined(SILENT_NO_TAINT_SUPPORT) /* silently ignore */ #elif defined(NO_TAINT_SUPPORT) Perl_croak_nocontext("This perl was compiled without taint support. " "Cowardly refusing to run with -t or -T flags"); #else - if( !TAINTING_get) { - TAINT_WARN_set(TRUE); - TAINTING_set(TRUE); - } -#endif - } else { - moreswitches(d); - } - } - } + if( !TAINTING_get) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); + } +#endif + } else { + moreswitches(d); + } + } + } } } @@ -2222,12 +2391,14 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) This could possibly be wasteful if PERL_INTERNAL_RAND_SEED is invalid, but avoids duplicating the logic from perl_construct(). */ - if (PL_tainting && + if (TAINT_get && PerlProc_getuid() == PerlProc_geteuid() && PerlProc_getgid() == PerlProc_getegid()) { Perl_drand48_init_r(&PL_internal_random_state, seed()); } #endif + if (DEBUG_h_TEST) + debug_hash_seed(true); /* Set $^X early so that it can be used for relocatable paths in @INC */ /* and for SITELIB_EXP in USE_SITECUSTOMIZE */ @@ -2238,101 +2409,95 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #if defined(USE_SITECUSTOMIZE) if (!minus_f) { - /* The games with local $! are to avoid setting errno if there is no - sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", - ie a q() operator with a NUL byte as a the delimiter. This avoids - problems with pathnames containing (say) ' */ + /* The games with local $! are to avoid setting errno if there is no + sitecustomize script. "q%c...%c", 0, ..., 0 becomes "q\0...\0", + ie a q() operator with a NUL byte as a the delimiter. This avoids + problems with pathnames containing (say) ' */ # ifdef PERL_IS_MINIPERL - AV *const inc = GvAV(PL_incgv); - SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; + AV *const inc = GvAV(PL_incgv); + SV **const inc0 = inc ? av_fetch(inc, 0, FALSE) : NULL; - if (inc0) { + if (inc0) { /* if lib/buildcustomize.pl exists, it should not fail. If it does, it should be reported immediately as a build failure. */ - (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ - "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " - "do {local $!; -f $f }" - " and do $f || die $@ || qq '$f: $!' }", + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ + "BEGIN { my $f = q%c%s%" SVf "/buildcustomize.pl%c; " + "do {local $!; -f $f }" + " and do $f || die $@ || qq '$f: $!' }", 0, (TAINTING_get ? "./" : ""), SVfARG(*inc0), 0)); - } + } # else - /* SITELIB_EXP is a function call on Win32. */ - const char *const raw_sitelib = SITELIB_EXP; - if (raw_sitelib) { - /* process .../.. if PERL_RELOCATABLE_INC is defined */ - SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), - INCPUSH_CAN_RELOCATE); - const char *const sitelib = SvPVX(sitelib_sv); - (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, - Perl_newSVpvf(aTHX_ - "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", - 0, SVfARG(sitelib), 0, - 0, SVfARG(sitelib), 0)); - assert (SvREFCNT(sitelib_sv) == 1); - SvREFCNT_dec(sitelib_sv); - } + /* SITELIB_EXP is a function call on Win32. */ + const char *const raw_sitelib = SITELIB_EXP; + if (raw_sitelib) { + /* process .../.. if PERL_RELOCATABLE_INC is defined */ + SV *sitelib_sv = mayberelocate(raw_sitelib, strlen(raw_sitelib), + INCPUSH_CAN_RELOCATE); + const char *const sitelib = SvPVX(sitelib_sv); + (void)Perl_av_create_and_unshift_one(aTHX_ &PL_preambleav, + Perl_newSVpvf(aTHX_ + "BEGIN { do {local $!; -f q%c%s/sitecustomize.pl%c} && do q%c%s/sitecustomize.pl%c }", + 0, sitelib, 0, + 0, sitelib, 0)); + assert (SvREFCNT(sitelib_sv) == 1); + SvREFCNT_dec(sitelib_sv); + } # endif } #endif if (!scriptname) - scriptname = argv[0]; + scriptname = argv[0]; if (PL_e_script) { - argc++,argv--; - scriptname = BIT_BUCKET; /* don't look for script or read stdin */ + argc++,argv--; + scriptname = BIT_BUCKET; /* don't look for script or read stdin */ } else if (scriptname == NULL) { -#ifdef MSDOS - if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) ) - moreswitches("h"); -#endif - scriptname = "-"; + scriptname = "-"; } assert (!TAINT_get); init_perllib(); { - bool suidscript = FALSE; + bool suidscript = FALSE; - rsfp = open_script(scriptname, dosearch, &suidscript); - if (!rsfp) { - rsfp = PerlIO_stdin(); - lex_start_flags = LEX_DONT_CLOSE_RSFP; - } + rsfp = open_script(scriptname, dosearch, &suidscript); + if (!rsfp) { + rsfp = PerlIO_stdin(); + lex_start_flags = LEX_DONT_CLOSE_RSFP; + } - validate_suid(rsfp); + validate_suid(rsfp); -#ifndef PERL_MICRO -# if defined(SIGCHLD) || defined(SIGCLD) - { -# ifndef SIGCHLD -# define SIGCHLD SIGCLD -# endif - Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == (Sighandler_t) SIG_IGN) { - Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), - "Can't ignore signal CHLD, forcing to default"); - (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); - } - } -# endif +#if defined(SIGCHLD) || defined(SIGCLD) + { +#ifndef SIGCHLD +# define SIGCHLD SIGCLD +#endif + Sighandler_t sigstate = rsignal_state(SIGCHLD); + if (sigstate == (Sighandler_t) SIG_IGN) { + Perl_ck_warner(aTHX_ packWARN(WARN_SIGNAL), + "Can't ignore signal CHLD, forcing to default"); + (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL); + } + } #endif - if (doextract) { + if (doextract) { - /* This will croak if suidscript is true, as -x cannot be used with - setuid scripts. */ - forbid_setid('x', suidscript); - /* Hence you can't get here if suidscript is true */ + /* This will croak if suidscript is true, as -x cannot be used with + setuid scripts. */ + forbid_setid('x', suidscript); + /* Hence you can't get here if suidscript is true */ - linestr_sv = newSV_type(SVt_PV); - lex_start_flags |= LEX_START_COPIED; - find_beginning(linestr_sv, rsfp); - if (cddir && PerlDir_chdir( (char *)cddir ) < 0) - Perl_croak(aTHX_ "Can't chdir to %s",cddir); - } + linestr_sv = newSV_type(SVt_PV); + lex_start_flags |= LEX_START_COPIED; + find_beginning(linestr_sv, rsfp); + if (cddir && PerlDir_chdir( (char *)cddir ) < 0) + Perl_croak(aTHX_ "Can't chdir to %s",cddir); + } } PL_main_cv = PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV)); @@ -2344,16 +2509,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) boot_core_PerlIO(); boot_core_UNIVERSAL(); + boot_core_builtin(); boot_core_mro(); newXS("Internals::V", S_Internals_V, __FILE__); if (xsinit) - (*xsinit)(aTHX); /* in case linked C routines want magical variables */ -#ifndef PERL_MICRO -#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) || defined(SYMBIAN) + (*xsinit)(aTHX); /* in case linked C routines want magical variables */ +#if defined(VMS) || defined(WIN32) || defined(__CYGWIN__) init_os_extras(); #endif -#endif #ifdef USE_SOCKS # ifdef HAS_SOCKS5_INIT @@ -2368,66 +2532,63 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* more than once (ENV isn't cleared first, for example) */ /* But running with -u leaves %ENV & @ARGV undefined! XXX */ if (!PL_do_undump) - init_postdump_symbols(argc,argv,env); + init_postdump_symbols(argc,argv,env); /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE}, * or explicitly in some platforms. * PL_utf8locale is conditionally turned on by * locale.c:Perl_init_i18nl10n() if the environment * look like the user wants to use UTF-8. */ -#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) { - IO* io; - PerlIO* fp; - SV* sv; - - /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR - * and the default open disciplines. */ - if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && - PL_stdingv && (io = GvIO(PL_stdingv)) && - (fp = IoIFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && - PL_defoutgv && (io = GvIO(PL_defoutgv)) && - (fp = IoOFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && - PL_stderrgv && (io = GvIO(PL_stderrgv)) && - (fp = IoOFP(io))) - PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); - if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && - (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, - SVt_PV)))) { - U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; - U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; - if (in) { - if (out) - sv_setpvs(sv, ":utf8\0:utf8"); - else - sv_setpvs(sv, ":utf8\0"); - } - else if (out) - sv_setpvs(sv, "\0:utf8"); - SvSETMAGIC(sv); - } - } + /* Requires init_predump_symbols(). */ + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + IO* io; + PerlIO* fp; + SV* sv; + + /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR + * and the default open disciplines. */ + if ((PL_unicode & PERL_UNICODE_STDIN_FLAG) && + PL_stdingv && (io = GvIO(PL_stdingv)) && + (fp = IoIFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDOUT_FLAG) && + PL_defoutgv && (io = GvIO(PL_defoutgv)) && + (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_STDERR_FLAG) && + PL_stderrgv && (io = GvIO(PL_stderrgv)) && + (fp = IoOFP(io))) + PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8"); + if ((PL_unicode & PERL_UNICODE_INOUT_FLAG) && + (sv = GvSV(gv_fetchpvs("\017PEN", GV_ADD|GV_NOTQUAL, + SVt_PV)))) { + U32 in = PL_unicode & PERL_UNICODE_IN_FLAG; + U32 out = PL_unicode & PERL_UNICODE_OUT_FLAG; + if (in) { + if (out) + sv_setpvs(sv, ":utf8\0:utf8"); + else + sv_setpvs(sv, ":utf8\0"); + } + else if (out) + sv_setpvs(sv, "\0:utf8"); + SvSETMAGIC(sv); + } + } } #endif { - const char *s; + const char *s; if ((s = PerlEnv_getenv("PERL_SIGNALS"))) { - if (strEQ(s, "unsafe")) - PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; - else if (strEQ(s, "safe")) - PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; - else - Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); + if (strEQ(s, "unsafe")) + PL_signals |= PERL_SIGNALS_UNSAFE_FLAG; + else if (strEQ(s, "safe")) + PL_signals &= ~PERL_SIGNALS_UNSAFE_FLAG; + else + Perl_croak(aTHX_ "PERL_SIGNALS illegal: \"%s\"", s); } } @@ -2438,28 +2599,30 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) PL_subname = newSVpvs("main"); if (add_read_e_script) - filter_add(read_e_script, NULL); + filter_add(read_e_script, NULL); /* now parse the script */ + if (minus_e == FALSE) + PL_hints |= HINTS_DEFAULT; /* after init_main_stash ; need to be after init_predump_symbols */ SETERRNO(0,SS_NORMAL); if (yyparse(GRAMPROG) || PL_parser->error_count) { - abort_execution("", PL_origfilename); + abort_execution(NULL, PL_origfilename); } CopLINE_set(PL_curcop, 0); SET_CURSTASH(PL_defstash); if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } if (PL_do_undump) - my_unexec(); + my_unexec(); if (isWARN_ONCE) { - SAVECOPFILE(PL_curcop); - SAVECOPLINE(PL_curcop); - gv_check(PL_defstash); + SAVECOPFILE(PL_curcop); + SAVECOPLINE(PL_curcop); + gv_check(PL_defstash); } LEAVE; @@ -2467,7 +2630,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef MYMALLOC { - const char *s; + const char *s; UV uv; s = PerlEnv_getenv("PERL_DEBUG_MSTATS"); if (s && grok_atoUV(s, &uv, NULL) && uv >= 2) @@ -2484,7 +2647,45 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* =for apidoc perl_run -Tells a Perl interpreter to run. See L. +Tells a Perl interpreter to run its main program. See L +for a tutorial. + +C points to the Perl interpreter. It must have been previously +created through the use of L and L, and +initialised through L. This function should not be called +if L returned a non-zero value, indicating a failure in +initialisation or compilation. + +This function executes code in C blocks, and then executes the +main program. The code to be executed is that established by the prior +call to L. If the interpreter's C word +does not have the C flag set, then this function +will also execute code in C blocks. If it is desired to make any +further use of the interpreter after calling this function, then C +blocks should be postponed to L time by setting that flag. + +Returns an integer of slightly tricky interpretation. The correct use +of the return value is as a truth value indicating whether the program +terminated non-locally. If zero is returned, this indicates that +the program ran to completion, and it is safe to make other use of the +interpreter (provided that the C flag was set as +described above). If a non-zero value is returned, this indicates that +the interpreter wants to terminate early. The interpreter should not be +just abandoned because of this desire to terminate; the caller should +proceed to shut the interpreter down cleanly with L +and free it with L. + +For historical reasons, the non-zero return value also attempts to +be a suitable value to pass to the C library function C (or to +return from C
), to serve as an exit code indicating the nature of +the way the program terminated. However, this isn't portable, due to +differing exit code conventions. An attempt is made to return an exit +code of the type required by the host operating system, but because +it is constrained to be non-zero, it is not necessarily possible to +indicate every type of exit. It is only reliable on Unix, where a zero +exit code can be augmented with a set bit that will be ignored. In any +case, this function is not the correct place to acquire an exit code: +one should get that from L. =cut */ @@ -2509,37 +2710,37 @@ perl_run(pTHXx) JMPENV_PUSH(ret); switch (ret) { case 1: - cxstack_ix = -1; /* start context stack again */ - goto redo_body; + cxstack_ix = -1; /* start context stack again */ + goto redo_body; case 0: /* normal completion */ redo_body: - run_body(oldscope); - /* FALLTHROUGH */ + run_body(oldscope); + /* FALLTHROUGH */ case 2: /* my_exit() */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && - PL_endav && !PL_minus_c) { - PERL_SET_PHASE(PERL_PHASE_END); - call_list(oldscope, PL_endav); - } + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + if (!(PL_exit_flags & PERL_EXIT_DESTRUCT_END) && + 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: "); + if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) + dump_mstats("after execution: "); #endif - ret = STATUS_EXIT; - break; + ret = STATUS_EXIT; + break; case 3: - if (PL_restartop) { - POPSTACK_TO(PL_mainstack); - goto redo_body; - } - PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); - FREETMPS; - ret = 1; - break; + if (PL_restartop) { + POPSTACK_TO(PL_mainstack); + goto redo_body; + } + PerlIO_printf(Perl_error_log, "panic: restartop in perl_run\n"); + FREETMPS; + ret = 1; + break; } JMPENV_POP; @@ -2555,25 +2756,25 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { #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")); + 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 - if (PL_minus_c) { - PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); - my_exit(0); - } - if (PERLDB_SINGLE && PL_DBsingle) + if (PL_minus_c) { + PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); + my_exit(0); + } + if (PERLDB_SINGLE && PL_DBsingle) PL_DBsingle_iv = 1; - if (PL_initav) { - PERL_SET_PHASE(PERL_PHASE_INIT); - call_list(oldscope, PL_initav); - } + if (PL_initav) { + PERL_SET_PHASE(PERL_PHASE_INIT); + call_list(oldscope, PL_initav); + } #ifdef PERL_DEBUG_READONLY_OPS - if (PL_main_root && PL_main_root->op_slabbed) - Slab_to_ro(OpSLAB(PL_main_root)); + if (PL_main_root && PL_main_root->op_slabbed) + Slab_to_ro(OpSLAB(PL_main_root)); #endif } @@ -2582,27 +2783,35 @@ S_run_body(pTHX_ I32 oldscope) PERL_SET_PHASE(PERL_PHASE_RUN); if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - CALLRUNOPS(aTHX); +#ifdef DEBUGGING + /* this complements the "EXECUTING..." debug we emit above. + * it will show up when an eval fails in the main program level + * and the code continues after the error. + */ + if (!DEBUG_q_TEST) + PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nCONTINUING...\n\n")); +#endif + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + CALLRUNOPS(aTHX); } else if (PL_main_start) { - CvDEPTH(PL_main_cv) = 1; - PL_op = PL_main_start; - CALLRUNOPS(aTHX); + CvDEPTH(PL_main_cv) = 1; + PL_op = PL_main_start; + CALLRUNOPS(aTHX); } my_exit(0); NOT_REACHED; /* NOTREACHED */ } /* -=head1 SV Manipulation Functions +=for apidoc_section $SV -=for apidoc p||get_sv +=for apidoc get_sv Returns the SV of the specified Perl scalar. C are passed to -C. If C is set and the +L>. 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. @@ -2618,20 +2827,21 @@ Perl_get_sv(pTHX_ const char *name, I32 flags) gv = gv_fetchpv(name, flags, SVt_PV); if (gv) - return GvSV(gv); + return GvSV(gv); return NULL; } /* -=head1 Array Manipulation Functions +=for apidoc_section $AV -=for apidoc p||get_av +=for apidoc get_av 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 +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. +(ignoring C) and the variable does not exist then C is +returned. Perl equivalent: C<@{"$name"}>. @@ -2645,22 +2855,23 @@ Perl_get_av(pTHX_ const char *name, I32 flags) PERL_ARGS_ASSERT_GET_AV; - if (flags) - return GvAVn(gv); + if (flags & ~SVf_UTF8) + return GvAVn(gv); if (gv) - return GvAV(gv); + return GvAV(gv); return NULL; } /* -=head1 Hash Manipulation Functions +=for apidoc_section $HV -=for apidoc p||get_hv +=for apidoc get_hv Returns the HV of the specified Perl hash. 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 C is returned. +(ignoring C) and the variable does not exist then C is +returned. =cut */ @@ -2672,27 +2883,34 @@ Perl_get_hv(pTHX_ const char *name, I32 flags) PERL_ARGS_ASSERT_GET_HV; - if (flags) - return GvHVn(gv); + if (flags & ~SVf_UTF8) + return GvHVn(gv); if (gv) - return GvHV(gv); + return GvHV(gv); return NULL; } /* -=head1 CV Manipulation Functions +=for apidoc_section $CV -=for apidoc p||get_cvn_flags +=for apidoc get_cv +=for apidoc_item get_cvn_flags +=for apidoc_item |CV *|get_cvs|"string"|I32 flags -Returns the CV of the specified Perl subroutine. C are passed to +These return the CV of the specified Perl subroutine. C are passed to C. If C is set and the Perl subroutine does not exist then it will be declared (which has the same effect as saying -C). If C is not set and the subroutine does not exist +C). If C is not set and the subroutine does not exist, then NULL is returned. -=for apidoc p||get_cv +The forms differ only in how the subroutine is specified.. With C, +the name is a literal C string, enclosed in double quotes. With C, the +name is given by the C parameter, which must be a NUL-terminated C +string. With C, the name is also given by the C +parameter, but it is a Perl string (possibly containing embedded NUL bytes), +and its length in bytes is contained in the C parameter. -Uses C to get the length of C, then calls C. +=for apidoc Amnh||GV_ADD =cut */ @@ -2705,16 +2923,16 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) PERL_ARGS_ASSERT_GET_CVN_FLAGS; if (gv && UNLIKELY(SvROK(gv)) && SvTYPE(SvRV((SV *)gv)) == SVt_PVCV) - return (CV*)SvRV((SV *)gv); + return (CV*)SvRV((SV *)gv); /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { - return newSTUB(gv,0); + return newSTUB(gv,0); } if (gv) - return GvCVu(gv); + return GvCVu(gv); return NULL; } @@ -2732,11 +2950,11 @@ Perl_get_cv(pTHX_ const char *name, I32 flags) /* -=head1 Callback Functions +=for apidoc_section $callback -=for apidoc p||call_argv +=for apidoc call_argv -Performs a callback to the specified named and package-scoped Perl subroutine +Performs a callback to the specified named and package-scoped Perl subroutine with C (a C-terminated array of strings) as arguments. See L. @@ -2745,37 +2963,44 @@ Approximate Perl equivalent: C<&{"$sub_name"}(@$argv)>. =cut */ -I32 +SSize_t Perl_call_argv(pTHX_ const char *sub_name, I32 flags, char **argv) - /* See G_* flags in cop.h */ - /* null terminated arg list */ + /* See G_* flags in cop.h */ + /* null terminated arg list */ { - dSP; - PERL_ARGS_ASSERT_CALL_ARGV; - PUSHMARK(SP); + bool is_rc = +#ifdef PERL_RC_STACK + rpp_stack_is_rc(); +#else + 0; +#endif + PUSHMARK(PL_stack_sp); while (*argv) { - mXPUSHs(newSVpv(*argv,0)); + SV *newsv = newSVpv(*argv,0); + rpp_extend(1); + *++PL_stack_sp = newsv; + if (!is_rc) + sv_2mortal(newsv); argv++; } - PUTBACK; return call_pv(sub_name, flags); } /* -=for apidoc p||call_pv +=for apidoc call_pv Performs a callback to the specified Perl sub. See L. =cut */ -I32 +SSize_t Perl_call_pv(pTHX_ const char *sub_name, I32 flags) - /* name of the subroutine */ - /* See G_* flags in cop.h */ + /* name of the subroutine */ + /* See G_* flags in cop.h */ { PERL_ARGS_ASSERT_CALL_PV; @@ -2783,7 +3008,7 @@ Perl_call_pv(pTHX_ const char *sub_name, I32 flags) } /* -=for apidoc p||call_method +=for apidoc call_method Performs a callback to the specified Perl method. The blessed object must be on the stack. See L. @@ -2791,10 +3016,10 @@ be on the stack. See L. =cut */ -I32 +SSize_t Perl_call_method(pTHX_ const char *methname, I32 flags) - /* name of the subroutine */ - /* See G_* flags in cop.h */ + /* name of the subroutine */ + /* See G_* flags in cop.h */ { STRLEN len; SV* sv; @@ -2810,7 +3035,7 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* May be called with any of a CV, a GV, or an SV containing the name. */ /* -=for apidoc p||call_sv +=for apidoc call_sv Performs a callback to the Perl sub specified by the SV. @@ -2829,58 +3054,68 @@ not be depended on. See L. +=for apidoc Amnh||G_METHOD +=for apidoc Amnh||G_METHOD_NAMED + =cut */ -I32 -Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) - /* See G_* flags in cop.h */ +SSize_t +Perl_call_sv(pTHX_ SV *sv, I32 arg_flags) + /* See G_* flags in cop.h */ { - dVAR; LOGOP myop; /* fake syntax tree node */ METHOP method_op; - I32 oldmark; - volatile I32 retval = 0; + SSize_t oldmark; + volatile SSize_t retval = 0; bool oldcatch = CATCH_GET; int ret; OP* const oldop = PL_op; + /* Since we don't modify flags after setjmp() we don't really need to make + flags volatile, but gcc complains that it could be clobbered anyway. + */ + volatile I32 flags = arg_flags; dJMPENV; PERL_ARGS_ASSERT_CALL_SV; if (flags & G_DISCARD) { - ENTER; - SAVETMPS; + ENTER; + SAVETMPS; } if (!(flags & G_WANT)) { - /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. - */ - flags |= G_SCALAR; + /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. + */ + flags |= G_SCALAR; } Zero(&myop, 1, LOGOP); if (!(flags & G_NOARGS)) - myop.op_flags |= OPf_STACKED; + myop.op_flags |= OPf_STACKED; myop.op_flags |= OP_GIMME_REVERSE(flags); + myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + myop.op_type = OP_ENTERSUB; SAVEOP(); PL_op = (OP*)&myop; if (!(flags & G_METHOD_NAMED)) { - dSP; - EXTEND(SP, 1); - PUSHs(sv); - PUTBACK; + rpp_extend(1); + *++PL_stack_sp = sv; +#ifdef PERL_RC_STACK + if (rpp_stack_is_rc()) + SvREFCNT_inc_simple_void_NN(sv); +#endif } oldmark = TOPMARK; if (PERLDB_SUB && PL_curstash != PL_debstash - /* Handle first BEGIN of -d. */ - && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) - /* Try harder, since this may have been a sighandler, thus - * curstash may be meaningless. */ - && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) - && !(flags & G_NODEBUG)) - myop.op_private |= OPpENTERSUB_DB; + /* Handle first BEGIN of -d. */ + && (PL_DBcv || (PL_DBcv = GvCV(PL_DBsub))) + /* Try harder, since this may have been a sighandler, thus + * curstash may be meaningless. */ + && (SvTYPE(sv) != SVt_PVCV || CvSTASH((const CV *)sv) != PL_debstash) + && !(flags & G_NODEBUG)) + myop.op_private |= OPpENTERSUB_DB; if (flags & (G_METHOD|G_METHOD_NAMED)) { Zero(&method_op, 1, METHOP); @@ -2894,77 +3129,85 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; method_op.op_type = OP_METHOD; } - myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; - myop.op_type = OP_ENTERSUB; } if (!(flags & G_EVAL)) { - CATCH_SET(TRUE); - CALL_BODY_SUB((OP*)&myop); - retval = PL_stack_sp - (PL_stack_base + oldmark); - CATCH_SET(oldcatch); + CATCH_SET(TRUE); + CALLRUNOPS(aTHX); + retval = PL_stack_sp - (PL_stack_base + oldmark); + CATCH_SET(oldcatch); } else { I32 old_cxix; - myop.op_other = (OP*)&myop; - (void)POPMARK; + myop.op_other = (OP*)&myop; + (void)POPMARK; old_cxix = cxstack_ix; - create_eval_scope(NULL, flags|G_FAKINGEVAL); - INCMARK; + create_eval_scope( NULL, PL_stack_base + oldmark, flags|G_FAKINGEVAL); + INCMARK; - JMPENV_PUSH(ret); + JMPENV_PUSH(ret); - switch (ret) { - case 0: + switch (ret) { + case 0: redo_body: - CALL_BODY_SUB((OP*)&myop); - retval = PL_stack_sp - (PL_stack_base + oldmark); - if (!(flags & G_KEEPERR)) { - CLEAR_ERRSV(); - } - break; - case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ - case 2: - /* my_exit() was called */ - SET_CURSTASH(PL_defstash); - FREETMPS; - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ - case 3: - if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } - PL_stack_sp = PL_stack_base + oldmark; - if ((flags & G_WANT) == G_ARRAY) - retval = 0; - else { - retval = 1; - *++PL_stack_sp = &PL_sv_undef; - } - break; - } + CALLRUNOPS(aTHX); + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) { + CLEAR_ERRSV(); + } + break; + case 1: + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ + case 2: + /* my_exit() was called */ + SET_CURSTASH(PL_defstash); + FREETMPS; + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ + case 3: + if (PL_restartop) { + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + goto redo_body; + } + /* Should be nothing left in stack frame apart from a possible + * scalar context undef. Assert it's safe to reset the stack */ + assert( PL_stack_sp == PL_stack_base + oldmark + || (PL_stack_sp == PL_stack_base + oldmark + 1 + && *PL_stack_sp == &PL_sv_undef)); + PL_stack_sp = PL_stack_base + oldmark; + if ((flags & G_WANT) == G_LIST) + retval = 0; + else { + retval = 1; + *++PL_stack_sp = &PL_sv_undef; + } + break; + } /* if we croaked, depending on how we croaked the eval scope * may or may not have already been popped */ - if (cxstack_ix > old_cxix) { + if (cxstack_ix > old_cxix) { assert(cxstack_ix == old_cxix + 1); assert(CxTYPE(CX_CUR()) == CXt_EVAL); - delete_eval_scope(); + delete_eval_scope(); } - JMPENV_POP; + JMPENV_POP; } if (flags & G_DISCARD) { - PL_stack_sp = PL_stack_base + oldmark; - retval = 0; - FREETMPS; - LEAVE; +#ifdef PERL_RC_STACK + if (rpp_stack_is_rc()) + rpp_popfree_to(PL_stack_base + oldmark); + else +#endif + PL_stack_sp = PL_stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; } PL_op = oldop; return retval; @@ -2973,23 +3216,31 @@ Perl_call_sv(pTHX_ SV *sv, volatile I32 flags) /* Eval a string. The G_EVAL flag is always assumed. */ /* -=for apidoc p||eval_sv +=for apidoc eval_sv Tells Perl to C the string in the SV. It supports the same flags as C, with the obvious exception of C. See L. +The C flag can be used if you only need eval_sv() to +execute code specified by a string, but not catch any errors. + +By default the code is compiled and executed with the default hints, +such as strict and features. Set C in flags to use the +current hints from C. + +=for apidoc Amnh||G_RETHROW +=for apidoc Amnh||G_USEHINTS =cut */ -I32 +SSize_t Perl_eval_sv(pTHX_ SV *sv, I32 flags) - /* See G_* flags in cop.h */ + /* See G_* flags in cop.h */ { - dVAR; UNOP myop; /* fake syntax tree node */ - volatile I32 oldmark; - volatile I32 retval = 0; + volatile SSize_t oldmark; + volatile SSize_t retval = 0; int ret; OP* const oldop = PL_op; dJMPENV; @@ -2997,30 +3248,37 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) PERL_ARGS_ASSERT_EVAL_SV; if (flags & G_DISCARD) { - ENTER; - SAVETMPS; + ENTER; + SAVETMPS; } SAVEOP(); PL_op = (OP*)&myop; Zero(&myop, 1, UNOP); - { - dSP; - oldmark = SP - PL_stack_base; - EXTEND(SP, 1); - PUSHs(sv); - PUTBACK; - } + myop.op_ppaddr = PL_ppaddr[OP_ENTEREVAL]; + myop.op_type = OP_ENTEREVAL; + + oldmark = PL_stack_sp - PL_stack_base; + rpp_extend(1); + *++PL_stack_sp = sv; +#ifdef PERL_RC_STACK + if (rpp_stack_is_rc()) + SvREFCNT_inc_simple_void_NN(sv); +#endif if (!(flags & G_NOARGS)) - myop.op_flags = OPf_STACKED; + myop.op_flags = OPf_STACKED; myop.op_type = OP_ENTEREVAL; myop.op_flags |= OP_GIMME_REVERSE(flags); if (flags & G_KEEPERR) - myop.op_flags |= OPf_SPECIAL; + myop.op_flags |= OPf_SPECIAL; + myop.op_private = (OPpEVAL_EVALSV); /* tell pp_entereval we're the caller */ if (flags & G_RE_REPARSING) - myop.op_private = (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); + myop.op_private |= (OPpEVAL_COPHH | OPpEVAL_RE_REPARSING); + + if (flags & G_USEHINTS) + myop.op_private |= OPpEVAL_COPHH; /* fail now; otherwise we could fail after the JMPENV_PUSH but * before a cx_pusheval(), which corrupts the stack after a croak */ @@ -3029,59 +3287,83 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) JMPENV_PUSH(ret); switch (ret) { case 0: - redo_body: - 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(); - } - break; + CALLRUNOPS(aTHX); + if (!*PL_stack_sp) { + /* In the presence of the OPpEVAL_EVALSV flag, + * pp_entereval() pushes a NULL pointer onto the stack to + * indicate compilation failure. Otherwise, the top slot on + * the stack will be a non-NULL pointer to whatever scalar or + * list value(s) the eval returned. In void context it will + * be whatever our caller has at the top of stack at the time, + * or the &PL_sv_undef guard at PL_stack_base[0]. Note that + * NULLs are not pushed on the stack except in a few very + * specific circumstances (such as this) to flag something + * special. */ + PL_stack_sp--; + goto fail; + } + redone_body: + retval = PL_stack_sp - (PL_stack_base + oldmark); + if (!(flags & G_KEEPERR)) { + CLEAR_ERRSV(); + } + break; case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ case 2: - /* my_exit() was called */ - SET_CURSTASH(PL_defstash); - FREETMPS; - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ + /* my_exit() was called */ + SET_CURSTASH(PL_defstash); + FREETMPS; + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ case 3: - if (PL_restartop) { - PL_restartjmpenv = NULL; - PL_op = PL_restartop; - PL_restartop = 0; - goto redo_body; - } + if (PL_restartop) { + PL_restartjmpenv = NULL; + PL_op = PL_restartop; + PL_restartop = 0; + CALLRUNOPS(aTHX); + goto redone_body; + } fail: - PL_stack_sp = PL_stack_base + oldmark; - if ((flags & G_WANT) == G_ARRAY) - retval = 0; - else { - retval = 1; - *++PL_stack_sp = &PL_sv_undef; - } - break; + if (flags & G_RETHROW) { + JMPENV_POP; + croak_sv(ERRSV); + } + /* Should be nothing left in stack frame apart from a possible + * scalar context undef. Assert it's safe to reset the stack */ + assert( PL_stack_sp == PL_stack_base + oldmark + || (PL_stack_sp == PL_stack_base + oldmark + 1 + && *PL_stack_sp == &PL_sv_undef)); + PL_stack_sp = PL_stack_base + oldmark; + if ((flags & G_WANT) == G_LIST) + retval = 0; + else { + retval = 1; + *++PL_stack_sp = &PL_sv_undef; + } + break; } JMPENV_POP; if (flags & G_DISCARD) { - PL_stack_sp = PL_stack_base + oldmark; - retval = 0; - FREETMPS; - LEAVE; +#ifdef PERL_RC_STACK + if (rpp_stack_is_rc()) + rpp_popfree_to(PL_stack_base + oldmark); + else +#endif + PL_stack_sp = PL_stack_base + oldmark; + retval = 0; + FREETMPS; + LEAVE; } PL_op = oldop; return retval; } /* -=for apidoc p||eval_pv +=for apidoc eval_pv Tells Perl to C the given string in scalar context and return an SV* result. @@ -3095,22 +3377,25 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) PERL_ARGS_ASSERT_EVAL_PV; - eval_sv(sv, G_SCALAR); - SvREFCNT_dec(sv); - - { - dSP; - sv = POPs; - PUTBACK; + if (croak_on_error) { + sv_2mortal(sv); + eval_sv(sv, G_SCALAR | G_RETHROW); + } + else { + eval_sv(sv, G_SCALAR); + SvREFCNT_dec(sv); } - /* just check empty string or undef? */ - if (croak_on_error) { - SV * const errsv = ERRSV; - if(SvTRUE_NN(errsv)) - /* replace with croak_sv? */ - Perl_croak_nocontext("%s", SvPV_nolen_const(errsv)); + sv = *PL_stack_sp; + +#ifdef PERL_RC_STACK + if (rpp_stack_is_rc()) { + SvREFCNT_inc_NN(sv_2mortal(sv)); + rpp_popfree_1(); } + else +#endif + PL_stack_sp--; return sv; } @@ -3118,9 +3403,9 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) /* Require a module. */ /* -=head1 Embedding Functions +=for apidoc_section $embedding -=for apidoc p||require_pv +=for apidoc require_pv Tells Perl to C the file named by the string argument. It is analogous to the Perl code C. It's even @@ -3151,34 +3436,35 @@ S_usage(pTHX) /* XXX move this out into a module ? */ /* 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)\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" +" -0[octal/hexadecimal] 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[t][:MOD] run program under debugger or module Devel::MOD\n" +" -D[number/letters] set debugging flags (argument is a bit mask or alphabets)\n", +" -e commandline one line of program (several -e's allowed, omit programfile)\n" +" -E commandline 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" +" -g read all input in one go (slurp), rather than line-by-line (alias for -0777)\n" +" -i[extension] edit <> files in place (makes backup if extension supplied)\n" +" -Idirectory specify @INC/#include directory (several -I's allowed)\n", +" -l[octnum] 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[:configvar] 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 @@ -3187,10 +3473,10 @@ NULL PerlIO *out = PerlIO_stdout(); PerlIO_printf(out, - "\nUsage: %s [switches] [--] [programfile] [arguments]\n", - PL_origargv[0]); + "\nUsage: %s [switches] [--] [programfile] [arguments]\n", + PL_origargv[0]); while (*p) - PerlIO_puts(out, *p++); + PerlIO_puts(out, *p++); my_exit(0); } @@ -3215,7 +3501,6 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " 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" " S Op slab allocation\n" @@ -3230,6 +3515,9 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " B dump suBroutine definitions, including special Blocks like BEGIN\n", " L trace some locale setting information--for Perl core development\n", " i trace PerlIO layer processing\n", + " y trace y///, tr/// compilation and execution\n", + " h Show (h)ash randomization debug output" + " (changes to PL_hash_rand_bits)\n", NULL }; UV uv = 0; @@ -3237,23 +3525,37 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) PERL_ARGS_ASSERT_GET_DEBUG_OPTS; if (isALPHA(**s)) { - /* if adding extra options, remember to update DEBUG_MASK */ - static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAqMBLi"; - - for (; isWORDCHAR(**s); (*s)++) { - const char * const d = strchr(debopts,**s); - if (d) - uv |= 1 << (d - debopts); - else if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "invalid option -D%c, use -D'' to see choices\n", **s); - } + /* NOTE: + * If adding new options add them to the END of debopts[]. + * If you remove an option replace it with a '?'. + * If there is a free slot available marked with '?' feel + * free to reuse it for something else. + * + * Regardless remember to update DEBUG_MASK in perl.h, and + * update the documentation above AND in pod/perlrun.pod. + * + * Note that the ? indicates an unused slot. As the code below + * indicates the position in this list is important. You cannot + * change the order or delete a character from the list without + * impacting the definitions of all the other flags in perl.h + * However because the logic is guarded by isWORDCHAR we can + * fill in holes with non-wordchar characters instead. */ + static const char debopts[] = "psltocPmfrxuUhXDSTRJvCAqMBLiy"; + + for (; isWORDCHAR(**s); (*s)++) { + const char * const d = strchr(debopts,**s); + if (d) + uv |= 1 << (d - debopts); + else if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "invalid option -D%c, use -D'' to see choices\n", **s); + } } else if (isDIGIT(**s)) { - const char* e; - if (grok_atoUV(*s, &uv, &e)) + const char* e = *s + strlen(*s); + if (grok_atoUV(*s, &uv, &e)) *s = e; - for (; isWORDCHAR(**s); (*s)++) ; + for (; isWORDCHAR(**s); (*s)++) ; } else if (givehelp) { const char *const *p = usage_msgd; @@ -3268,7 +3570,6 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) const char * Perl_moreswitches(pTHX_ const char *s) { - dVAR; UV rschar; const char option = *s; /* used to remember option in -m/-M code */ @@ -3277,259 +3578,279 @@ Perl_moreswitches(pTHX_ const char *s) switch (*s) { case '0': { - I32 flags = 0; - STRLEN numlen; - - SvREFCNT_dec(PL_rs); - if (s[1] == 'x' && s[2]) { - const char *e = s+=2; - U8 *tmps; - - while (*e) - e++; - numlen = e - s; - flags = PERL_SCAN_SILENT_ILLDIGIT; - rschar = (U32)grok_hex(s, &numlen, &flags, NULL); - if (s + numlen < e) { - rschar = 0; /* Grandfather -0xFOO as -0 -xFOO. */ - numlen = 0; - s--; - } - PL_rs = newSVpvs(""); - tmps = (U8*) SvGROW(PL_rs, (STRLEN)(UVCHR_SKIP(rschar) + 1)); - uvchr_to_utf8(tmps, rschar); - SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); - SvUTF8_on(PL_rs); - } - else { - numlen = 4; - rschar = (U32)grok_oct(s, &numlen, &flags, NULL); - if (rschar & ~((U8)~0)) - PL_rs = &PL_sv_undef; - else if (!rschar && numlen >= 2) - PL_rs = newSVpvs(""); - else { - char ch = (char)rschar; - PL_rs = newSVpvn(&ch, 1); - } - } - sv_setsv(get_sv("/", GV_ADD), PL_rs); - return s + numlen; + I32 flags = 0; + STRLEN numlen; + + SvREFCNT_dec(PL_rs); + if (s[1] == 'x' && s[2]) { + const char *e = s+=2; + U8 *tmps; + + while (*e) + e++; + numlen = e - s; + flags = PERL_SCAN_SILENT_ILLDIGIT; + rschar = (U32)grok_hex(s, &numlen, &flags, NULL); + if (s + numlen < e) { + /* Continue to treat -0xFOO as -0 -xFOO + * (ie NUL as the input record separator, and -x with FOO + * as the directory argument) + * + * hex support for -0 was only added in 5.8.1, hence this + * heuristic to distinguish between it and '-0' clustered with + * '-x' with an argument. The text following '-0x' is only + * processed as the IRS specified in hexadecimal if all + * characters are valid hex digits. */ + rschar = 0; + numlen = 0; + s--; + } + PL_rs = newSV((STRLEN)(UVCHR_SKIP(rschar) + 1)); + tmps = (U8*)SvPVCLEAR_FRESH(PL_rs); + uvchr_to_utf8(tmps, rschar); + SvCUR_set(PL_rs, UVCHR_SKIP(rschar)); + SvUTF8_on(PL_rs); + } + else { + numlen = 4; + rschar = (U32)grok_oct(s, &numlen, &flags, NULL); + if (rschar & ~((U8)~0)) + PL_rs = &PL_sv_undef; + else if (!rschar && numlen >= 2) + PL_rs = newSVpvs(""); + else { + char ch = (char)rschar; + PL_rs = newSVpvn(&ch, 1); + } + } + sv_setsv(get_sv("/", GV_ADD), PL_rs); + return s + numlen; } case 'C': s++; PL_unicode = parse_unicode_opts( (const char **)&s ); - if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) - PL_utf8cache = -1; - return s; + if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG) + PL_utf8cache = -1; + return s; case 'F': - PL_minus_a = TRUE; - PL_minus_F = TRUE; + PL_minus_a = TRUE; + PL_minus_F = TRUE; PL_minus_n = TRUE; - PL_splitstr = ++s; - while (*s && !isSPACE(*s)) ++s; - PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr); - return s; + { + const char *start = ++s; + while (*s && !isSPACE(*s)) ++s; + Safefree(PL_splitstr); + PL_splitstr = savepvn(start, s - start); + } + return s; case 'a': - PL_minus_a = TRUE; + PL_minus_a = TRUE; PL_minus_n = TRUE; - s++; - return s; + s++; + return s; case 'c': - PL_minus_c = TRUE; - s++; - return s; + PL_minus_c = TRUE; + s++; + return s; case 'd': - forbid_setid('d', FALSE); - s++; + forbid_setid('d', FALSE); + s++; /* -dt indicates to the debugger that threads will be used */ - if (*s == 't' && !isWORDCHAR(s[1])) { - ++s; - my_setenv("PERL5DB_THREADED", "1"); - } - - /* The following permits -d:Mod to accepts arguments following an = - in the fashion that -MSome::Mod does. */ - if (*s == ':' || *s == '=') { - 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 and -d:-Module */ - while(isWORDCHAR(*s) || *s==':') ++s; - if (*s != '=') - sv_catpvn(sv, start, end - start); - else { - sv_catpvn(sv, start, s-start); - /* Don't use NUL as q// delimiter here, this string goes in the - * environment. */ - Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); - } - s = end; - my_setenv("PERL5DB", SvPV_nolen_const(sv)); - SvREFCNT_dec(sv); - } - if (!PL_perldb) { - PL_perldb = PERLDB_ALL; - init_debugger(); - } - return s; + if (*s == 't' && !isWORDCHAR(s[1])) { + ++s; + my_setenv("PERL5DB_THREADED", "1"); + } + + /* The following permits -d:Mod to accepts arguments following an = + in the fashion that -MSome::Mod does. */ + if (*s == ':' || *s == '=') { + 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 and -d:-Module */ + while(isWORDCHAR(*s) || *s==':') ++s; + if (*s != '=') + sv_catpvn(sv, start, end - start); + else { + sv_catpvn(sv, start, s-start); + /* Don't use NUL as q// delimiter here, this string goes in the + * environment. */ + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q{%s});", ++s); + } + s = end; + my_setenv("PERL5DB", SvPV_nolen_const(sv)); + SvREFCNT_dec(sv); + } + if (!PL_perldb) { + PL_perldb = PERLDB_ALL; + init_debugger(); + } + return s; case 'D': - { + { #ifdef DEBUGGING - forbid_setid('D', FALSE); - s++; - PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; + forbid_setid('D', FALSE); + s++; + PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ - if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), - "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); - for (s++; isWORDCHAR(*s); s++) ; + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), + "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); + for (s++; isWORDCHAR(*s); s++) ; #endif - return s; + return s; NOT_REACHED; /* NOTREACHED */ - } + } + case 'g': + SvREFCNT_dec(PL_rs); + PL_rs = &PL_sv_undef; + sv_setsv(get_sv("/", GV_ADD), PL_rs); + return ++s; + + case '?': + /* FALLTHROUGH */ case 'h': - usage(); + usage(); NOT_REACHED; /* NOTREACHED */ case 'i': - Safefree(PL_inplace); - { - const char * const start = ++s; - while (*s && !isSPACE(*s)) - ++s; - - PL_inplace = savepvn(start, s - start); - } - return s; + Safefree(PL_inplace); + { + const char * const start = ++s; + while (*s && !isSPACE(*s)) + ++s; + + PL_inplace = savepvn(start, s - start); + } + return s; case 'I': /* -I handled both here and in parse_body() */ - forbid_setid('I', FALSE); - ++s; - while (*s && isSPACE(*s)) - ++s; - if (*s) { - const char *e, *p; - p = s; - /* ignore trailing spaces (possibly followed by other switches) */ - do { - for (e = p; *e && !isSPACE(*e); e++) ; - p = e; - while (isSPACE(*p)) - p++; - } while (*p && *p != '-'); - incpush(s, e-s, - INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); - s = p; - if (*s == '-') - s++; - } - else - Perl_croak(aTHX_ "No directory specified for -I"); - return s; + forbid_setid('I', FALSE); + ++s; + while (*s && isSPACE(*s)) + ++s; + if (*s) { + const char *e, *p; + p = s; + /* ignore trailing spaces (possibly followed by other switches) */ + do { + for (e = p; *e && !isSPACE(*e); e++) ; + p = e; + while (isSPACE(*p)) + p++; + } while (*p && *p != '-'); + incpush(s, e-s, + INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT); + s = p; + if (*s == '-') + s++; + } + else + Perl_croak(aTHX_ "No directory specified for -I"); + return s; case 'l': - PL_minus_l = TRUE; - s++; - if (PL_ors_sv) { - SvREFCNT_dec(PL_ors_sv); - PL_ors_sv = NULL; - } - if (isDIGIT(*s)) { + PL_minus_l = TRUE; + s++; + if (PL_ors_sv) { + SvREFCNT_dec(PL_ors_sv); + PL_ors_sv = NULL; + } + if (isDIGIT(*s)) { I32 flags = 0; - STRLEN numlen; - PL_ors_sv = newSVpvs("\n"); - numlen = 3 + (*s == '0'); - *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); - s += numlen; - } - else { - if (RsPARA(PL_rs)) { - PL_ors_sv = newSVpvs("\n\n"); - } - else { - PL_ors_sv = newSVsv(PL_rs); - } - } - return s; + STRLEN numlen; + PL_ors_sv = newSVpvs("\n"); + numlen = 3 + (*s == '0'); + *SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL); + s += numlen; + } + else { + if (RsPARA(PL_rs)) { + PL_ors_sv = newSVpvs("\n\n"); + } + else { + PL_ors_sv = newSVsv(PL_rs); + } + } + return s; case 'M': - forbid_setid('M', FALSE); /* XXX ? */ - /* FALLTHROUGH */ + forbid_setid('M', FALSE); /* XXX ? */ + /* FALLTHROUGH */ case 'm': - forbid_setid('m', FALSE); /* XXX ? */ - if (*++s) { - const char *start; - const char *end; - SV *sv; - const char *use = "use "; - bool colon = FALSE; - /* -M-foo == 'no foo' */ - /* Leading space on " no " is deliberate, to make both - possibilities the same length. */ - if (*s == '-') { use = " no "; ++s; } - sv = newSVpvn(use,4); - start = s; - /* We allow -M'Module qw(Foo Bar)' */ - while(isWORDCHAR(*s) || *s==':') { - if( *s++ == ':' ) { - if( *s == ':' ) - s++; - else - colon = TRUE; - } - } - if (s == start) - Perl_croak(aTHX_ "Module name required with -%c option", - option); - if (colon) - Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " - "contains single ':'", - (int)(s - start), start, option); - end = s + strlen(s); - if (*s != '=') { - sv_catpvn(sv, start, end - start); - if (option == 'm') { - if (*s != '\0') - Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); - sv_catpvs( sv, " ()"); - } - } else { - sv_catpvn(sv, start, s-start); - /* Use NUL as q''-delimiter. */ - sv_catpvs(sv, " split(/,/,q\0"); - ++s; - sv_catpvn(sv, s, end - s); - sv_catpvs(sv, "\0)"); - } - s = end; - Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); - } - else - Perl_croak(aTHX_ "Missing argument to -%c", option); - return s; + forbid_setid('m', FALSE); /* XXX ? */ + if (*++s) { + const char *start; + const char *end; + SV *sv; + const char *use = "use "; + bool colon = FALSE; + /* -M-foo == 'no foo' */ + /* Leading space on " no " is deliberate, to make both + possibilities the same length. */ + if (*s == '-') { use = " no "; ++s; } + sv = newSVpvn(use,4); + start = s; + /* We allow -M'Module qw(Foo Bar)' */ + while(isWORDCHAR(*s) || *s==':') { + if( *s++ == ':' ) { + if( *s == ':' ) + s++; + else + colon = TRUE; + } + } + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + option); + if (colon) + Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " + "contains single ':'", + (int)(s - start), start, option); + end = s + strlen(s); + if (*s != '=') { + sv_catpvn(sv, start, end - start); + if (option == 'm') { + if (*s != '\0') + Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); + sv_catpvs( sv, " ()"); + } + } else { + sv_catpvn(sv, start, s-start); + /* Use NUL as q''-delimiter. */ + sv_catpvs(sv, " split(/,/,q\0"); + ++s; + sv_catpvn(sv, s, end - s); + sv_catpvs(sv, "\0)"); + } + s = end; + Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); + } + else + Perl_croak(aTHX_ "Missing argument to -%c", option); + return s; case 'n': - PL_minus_n = TRUE; - s++; - return s; + PL_minus_n = TRUE; + s++; + return s; case 'p': - PL_minus_p = TRUE; - s++; - return s; + PL_minus_p = TRUE; + s++; + return s; case 's': - forbid_setid('s', FALSE); - PL_doswitches = TRUE; - s++; - return s; + forbid_setid('s', FALSE); + PL_doswitches = TRUE; + s++; + return s; case 't': case 'T': #if defined(SILENT_NO_TAINT_SUPPORT) @@ -3539,47 +3860,43 @@ Perl_moreswitches(pTHX_ const char *s) "Cowardly refusing to run with -t or -T flags"); #else if (!TAINTING_get) - TOO_LATE_FOR(*s); + TOO_LATE_FOR(*s); #endif s++; - return s; + return s; case 'u': - PL_do_undump = TRUE; - s++; - return s; + PL_do_undump = TRUE; + s++; + return s; case 'U': - PL_unsafe = TRUE; - s++; - return s; + PL_unsafe = TRUE; + s++; + return s; case 'v': - minus_v(); + minus_v(); case 'w': - if (! (PL_dowarn & G_WARN_ALL_MASK)) { - PL_dowarn |= G_WARN_ON; - } - s++; - return s; + if (! (PL_dowarn & G_WARN_ALL_MASK)) { + PL_dowarn |= G_WARN_ON; + } + s++; + return s; case 'W': - PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; - if (!specialWARN(PL_compiling.cop_warnings)) - PerlMemShared_free(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = pWARN_ALL ; - s++; - return s; + PL_dowarn = G_WARN_ALL_ON|G_WARN_ON; + free_and_set_cop_warnings(&PL_compiling, pWARN_ALL); + s++; + return s; case 'X': - PL_dowarn = G_WARN_ALL_OFF; - if (!specialWARN(PL_compiling.cop_warnings)) - PerlMemShared_free(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = pWARN_NONE ; - s++; - return s; + PL_dowarn = G_WARN_ALL_OFF; + free_and_set_cop_warnings(&PL_compiling, pWARN_NONE); + s++; + return s; case '*': case ' ': while( *s == ' ' ) ++s; - if (s[0] == '-') /* Additional switches on #! line. */ - return s+1; - break; + if (s[0] == '-') /* Additional switches on #! line. */ + return s+1; + break; case '-': case 0: #if defined(WIN32) || !defined(PERL_STRICT_CR) @@ -3587,21 +3904,21 @@ Perl_moreswitches(pTHX_ const char *s) #endif case '\n': case '\t': - break; + break; #ifdef ALTERNATE_SHEBANG case 'S': /* OS/2 needs -S on "extproc" line. */ - break; + break; #endif case 'e': case 'f': case 'x': case 'E': #ifndef ALTERNATE_SHEBANG case 'S': #endif case 'V': - Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); + Perl_croak(aTHX_ "Can't emulate -%.1s on #! line",s); default: - Perl_croak(aTHX_ - "Unrecognized switch: -%.1s (-h will show valid options)",s - ); + Perl_croak(aTHX_ + "Unrecognized switch: -%.1s (-h will show valid options)",s + ); } return NULL; } @@ -3610,103 +3927,84 @@ Perl_moreswitches(pTHX_ const char *s) STATIC void S_minus_v(pTHX) { - PerlIO * PIO_stdout; - { - const char * const level_str = "v" PERL_VERSION_STRING; - const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; + PerlIO * PIO_stdout; + { + const char * const level_str = "v" PERL_VERSION_STRING; + const STRLEN level_len = sizeof("v" PERL_VERSION_STRING)-1; #ifdef PERL_PATCHNUM - SV* level; + SV* level; # ifdef PERL_GIT_UNCOMMITTED_CHANGES - static const char num [] = PERL_PATCHNUM "*"; + static const char num [] = PERL_PATCHNUM "*"; # else - static const char num [] = PERL_PATCHNUM; + static const char num [] = PERL_PATCHNUM; # endif - { - const STRLEN num_len = sizeof(num)-1; - /* A very advanced compiler would fold away the strnEQ - and this whole conditional, but most (all?) won't do it. - SV level could also be replaced by with preprocessor - catenation. - */ - if (num_len >= level_len && strnEQ(num,level_str,level_len)) { - /* per 46807d8e80, PERL_PATCHNUM is outside of the control - of the interp so it might contain format characters - */ - level = newSVpvn(num, num_len); - } else { - level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); - } - } + { + const STRLEN num_len = sizeof(num)-1; + /* A very advanced compiler would fold away the strnEQ + and this whole conditional, but most (all?) won't do it. + SV level could also be replaced by with preprocessor + catenation. + */ + if (num_len >= level_len && strnEQ(num,level_str,level_len)) { + /* per 46807d8e80, PERL_PATCHNUM is outside of the control + of the interp so it might contain format characters + */ + level = newSVpvn(num, num_len); + } else { + level = Perl_newSVpvf_nocontext("%s (%s)", level_str, num); + } + } #else - SV* level = newSVpvn(level_str, level_len); + SV* level = newSVpvn(level_str, level_len); #endif /* #ifdef PERL_PATCHNUM */ - PIO_stdout = PerlIO_stdout(); - PerlIO_printf(PIO_stdout, - "\nThis is perl " STRINGIFY(PERL_REVISION) - ", version " STRINGIFY(PERL_VERSION) - ", subversion " STRINGIFY(PERL_SUBVERSION) - " (%" SVf ") built for " ARCHNAME, SVfARG(level) - ); - SvREFCNT_dec_NN(level); - } + PIO_stdout = PerlIO_stdout(); + PerlIO_printf(PIO_stdout, + "\nThis is perl " STRINGIFY(PERL_REVISION) + ", version " STRINGIFY(PERL_VERSION) + ", subversion " STRINGIFY(PERL_SUBVERSION) + " (%" SVf ") built for " ARCHNAME, SVfARG(level) + ); + SvREFCNT_dec_NN(level); + } #if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) - PerlIO_printf(PIO_stdout, - "\n(with %d registered patch%s, " - "see perl -V for more detail)", - LOCAL_PATCH_COUNT, - (LOCAL_PATCH_COUNT!=1) ? "es" : ""); + if (LOCAL_PATCH_COUNT > 0) + PerlIO_printf(PIO_stdout, + "\n(with %d registered patch%s, " + "see perl -V for more detail)", + LOCAL_PATCH_COUNT, + (LOCAL_PATCH_COUNT!=1) ? "es" : ""); #endif - PerlIO_printf(PIO_stdout, - "\n\nCopyright 1987-2017, Larry Wall\n"); -#ifdef MSDOS - PerlIO_printf(PIO_stdout, - "\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n"); -#endif -#ifdef DJGPP - PerlIO_printf(PIO_stdout, - "djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n" - "djgpp v2 port (perl5004+) by Laszlo Molnar, 1997-1999\n"); -#endif + PerlIO_printf(PIO_stdout, + "\n\nCopyright 1987-2024, Larry Wall\n"); #ifdef OS2 - PerlIO_printf(PIO_stdout, - "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" - "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); + PerlIO_printf(PIO_stdout, + "\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n" + "Version 5 port Copyright (c) 1994-2002, Andreas Kaiser, Ilya Zakharevich\n"); #endif #ifdef OEMVS - PerlIO_printf(PIO_stdout, - "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); + PerlIO_printf(PIO_stdout, + "MVS (OS390) port by Mortice Kern Systems, 1997-1999\n"); #endif #ifdef __VOS__ - PerlIO_printf(PIO_stdout, - "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); + PerlIO_printf(PIO_stdout, + "Stratus OpenVOS port by Paul.Green@stratus.com, 1997-2013\n"); #endif #ifdef POSIX_BC - PerlIO_printf(PIO_stdout, - "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); -#endif -#ifdef UNDER_CE - PerlIO_printf(PIO_stdout, - "WINCE port by Rainer Keuchel, 2001-2002\n" - "Built on " __DATE__ " " __TIME__ "\n\n"); - wce_hitreturn(); -#endif -#ifdef __SYMBIAN32__ - PerlIO_printf(PIO_stdout, - "Symbian port by Nokia, 2004-2005\n"); + PerlIO_printf(PIO_stdout, + "BS2000 (POSIX) port by Start Amadeus GmbH, 1998-1999\n"); #endif #ifdef BINARY_BUILD_NOTICE - BINARY_BUILD_NOTICE; + BINARY_BUILD_NOTICE; #endif - PerlIO_printf(PIO_stdout, - "\n\ + PerlIO_printf(PIO_stdout, + "\n\ Perl may be copied only under the terms of either the Artistic License or the\n\ GNU General Public License, which may be found in the Perl 5 source kit.\n\n\ Complete documentation for Perl, including FAQ lists, should be found on\n\ this system using \"man perl\" or \"perldoc perl\". If you have access to the\n\ -Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n"); - my_exit(0); +Internet, point your browser at https://www.perl.org/, the Perl Home Page.\n\n"); + my_exit(0); } /* compliments of Tom Christiansen */ @@ -3752,7 +4050,7 @@ S_init_interp(pTHX) #ifdef MULTIPLICITY # define PERLVAR(prefix,var,type) # define PERLVARA(prefix,var,n,type) -# if defined(PERL_IMPLICIT_CONTEXT) +# if defined(MULTIPLICITY) # define PERLVARI(prefix,var,type,init) aTHX->prefix##var = init; # define PERLVARIC(prefix,var,type,init) aTHX->prefix##var = init; # else @@ -3782,8 +4080,9 @@ STATIC void S_init_main_stash(pTHX) { GV *gv; + HV *hv = newHV(); - PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(newHV()); + PL_curstash = PL_defstash = (HV *)SvREFCNT_inc_simple_NN(hv); /* We know that the string "main" will be in the global shared string table, so it's a small saving to use it rather than allocate another 8 bytes. */ @@ -3798,7 +4097,7 @@ S_init_main_stash(pTHX) GvHV(gv) = MUTABLE_HV(SvREFCNT_inc_simple(PL_defstash)); SvREADONLY_on(gv); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpvs("INC", GV_ADD|GV_NOTQUAL, - SVt_PVAV))); + SVt_PVAV))); SvREFCNT_inc_simple_void(PL_incgv); /* Don't allow it to be freed */ GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpvs("\010", GV_ADD|GV_NOTQUAL, SVt_PV); /* ^H */ @@ -3821,7 +4120,7 @@ S_init_main_stash(pTHX) CopSTASH_set(&PL_compiling, PL_defstash); PL_debstash = GvHV(gv_fetchpvs("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpvs("CORE::GLOBAL::", GV_ADDMULTI, - SVt_PVHV)); + SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvs(get_sv("/", GV_ADD), "\n"); } @@ -3837,116 +4136,104 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript) PERL_ARGS_ASSERT_OPEN_SCRIPT; if (PL_e_script) { - PL_origfilename = savepvs("-e"); + PL_origfilename = savepvs("-e"); } else { const char *s; UV uv; - /* if find_script() returns, it returns a malloc()-ed value */ - scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); + /* if find_script() returns, it returns a malloc()-ed value */ + scriptname = PL_origfilename = find_script(scriptname, dosearch, NULL, 1); + s = scriptname + strlen(scriptname); - if (strBEGINs(scriptname, "/dev/fd/") + if (strBEGINs(scriptname, "/dev/fd/") && isDIGIT(scriptname[8]) && grok_atoUV(scriptname + 8, &uv, &s) && uv <= PERL_INT_MAX ) { fdscript = (int)uv; - if (*s) { - /* PSz 18 Feb 04 - * Tell apart "normal" usage of fdscript, e.g. - * with bash on FreeBSD: - * perl <( echo '#!perl -DA'; echo 'print "$0\n"') - * from usage in suidperl. - * Does any "normal" usage leave garbage after the number??? - * Is it a mistake to use a similar /dev/fd/ construct for - * suidperl? - */ - *suidscript = TRUE; - /* PSz 20 Feb 04 - * Be supersafe and do some sanity-checks. - * Still, can we be sure we got the right thing? - */ - if (*s != '/') { - Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); - } - if (! *(s+1)) { - Perl_croak(aTHX_ "Missing (suid) fd script name\n"); - } - scriptname = savepv(s + 1); - Safefree(PL_origfilename); - PL_origfilename = (char *)scriptname; - } - } + if (*s) { + /* PSz 18 Feb 04 + * Tell apart "normal" usage of fdscript, e.g. + * with bash on FreeBSD: + * perl <( echo '#!perl -DA'; echo 'print "$0\n"') + * from usage in suidperl. + * Does any "normal" usage leave garbage after the number??? + * Is it a mistake to use a similar /dev/fd/ construct for + * suidperl? + */ + *suidscript = TRUE; + /* PSz 20 Feb 04 + * Be supersafe and do some sanity-checks. + * Still, can we be sure we got the right thing? + */ + if (*s != '/') { + Perl_croak(aTHX_ "Wrong syntax (suid) fd script name \"%s\"\n", s); + } + if (! *(s+1)) { + Perl_croak(aTHX_ "Missing (suid) fd script name\n"); + } + scriptname = savepv(s + 1); + Safefree(PL_origfilename); + PL_origfilename = (char *)scriptname; + } + } } CopFILE_free(PL_curcop); CopFILE_set(PL_curcop, PL_origfilename); if (*PL_origfilename == '-' && PL_origfilename[1] == '\0') - scriptname = (char *)""; + scriptname = (char *)""; if (fdscript >= 0) { - rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); + rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE); } else if (!*scriptname) { - forbid_setid(0, *suidscript); - return NULL; + forbid_setid(0, *suidscript); + return NULL; } else { #ifdef FAKE_BIT_BUCKET - /* This hack allows one not to have /dev/null (or BIT_BUCKET as it - * is called) and still have the "-e" work. (Believe it or not, - * a /dev/null is required for the "-e" to work because source - * filter magic is used to implement it. ) This is *not* a general - * replacement for a /dev/null. What we do here is create a temp - * file (an empty file), open up that as the script, and then - * immediately close and unlink it. Close enough for jazz. */ + /* This hack allows one not to have /dev/null (or BIT_BUCKET as it + * is called) and still have the "-e" work. (Believe it or not, + * a /dev/null is required for the "-e" to work because source + * filter magic is used to implement it. ) This is *not* a general + * replacement for a /dev/null. What we do here is create a temp + * file (an empty file), open up that as the script, and then + * immediately close and unlink it. Close enough for jazz. */ #define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-" #define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX" #define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX - char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { - FAKE_BIT_BUCKET_TEMPLATE - }; - const char * const err = "Failed to create a fake bit bucket"; - if (strEQ(scriptname, BIT_BUCKET)) { -#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */ - int old_umask = umask(0177); - int tmpfd = mkstemp(tmpname); - umask(old_umask); - if (tmpfd > -1) { - scriptname = tmpname; - close(tmpfd); - } else - Perl_croak(aTHX_ err); -#endif - } -#endif - rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); + char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = { + FAKE_BIT_BUCKET_TEMPLATE + }; + const char * const err = "Failed to create a fake bit bucket"; + if (strEQ(scriptname, BIT_BUCKET)) { + int tmpfd = Perl_my_mkstemp_cloexec(tmpname); + if (tmpfd > -1) { + scriptname = tmpname; + close(tmpfd); + } else + Perl_croak(aTHX_ err); + } +#endif + rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE); #ifdef FAKE_BIT_BUCKET if ( strBEGINs(scriptname, FAKE_BIT_BUCKET_PREFIX) - && strlen(scriptname) == sizeof(tmpname) - 1) + && strlen(scriptname) == sizeof(tmpname) - 1) { - unlink(scriptname); - } - scriptname = BIT_BUCKET; + unlink(scriptname); + } + scriptname = BIT_BUCKET; #endif } if (!rsfp) { - /* PSz 16 Sep 03 Keep neat error message */ - if (PL_e_script) - Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno)); - else - Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); - } - fd = PerlIO_fileno(rsfp); -#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC) - if (fd >= 0) { - /* ensure close-on-exec */ - if (fcntl(fd, F_SETFD, FD_CLOEXEC) < 0) { + /* PSz 16 Sep 03 Keep neat error message */ + if (PL_e_script) + Perl_croak(aTHX_ "Can't open " BIT_BUCKET ": %s\n", Strerror(errno)); + else Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n", - CopFILE(PL_curcop), Strerror(errno)); - } + CopFILE(PL_curcop), Strerror(errno)); } -#endif + fd = PerlIO_fileno(rsfp); if (fd < 0 || (PerlLIO_fstat(fd, &tmpstatbuf) >= 0 @@ -3988,7 +4275,6 @@ S_validate_suid(pTHX_ PerlIO *rsfp) PERL_ARGS_ASSERT_VALIDATE_SUID; if (my_euid != my_uid || my_egid != my_gid) { /* (suidperl doesn't exist, in fact) */ - dVAR; int fd = PerlIO_fileno(rsfp); Stat_t statbuf; if (fd < 0 || PerlLIO_fstat(fd, &statbuf) < 0) { /* may be either wrapped or real suid */ @@ -3998,10 +4284,10 @@ S_validate_suid(pTHX_ PerlIO *rsfp) || (my_egid != my_gid && my_egid == statbuf.st_gid && statbuf.st_mode & S_ISGID) ) - if (!PL_do_undump) - Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ + if (!PL_do_undump) + Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); - /* not set-id, must be wrapped */ + /* not set-id, must be wrapped */ } } #endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ @@ -4017,20 +4303,20 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) /* skip forward in input to the real script? */ do { - if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) - Perl_croak(aTHX_ "No Perl script found in input\n"); - s2 = s; + if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) + Perl_croak(aTHX_ "No Perl script found in input\n"); + s2 = 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 (strBEGINs(s2-4,"perl")) - while ((s = moreswitches(s))) - ; + while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' + || s2[-1] == '_') s2--; + if (strBEGINs(s2-4,"perl")) + while ((s = moreswitches(s))) + ; } } @@ -4075,9 +4361,9 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) * function is to be called at such an early stage. If you are on * a system with PERL_IMPLICIT_SYS but you do have a concept of * "tainted because running with altered effective ids', you'll - * have to add your own checks somewhere in here. The two most - * known samples of 'implicitness' are Win32 and NetWare, neither - * of which has much of concept of 'uids'. */ + * have to add your own checks somewhere in here. The most known + * sample of 'implicitness' is Win32, which doesn't have much of + * concept of 'uids'. */ Uid_t uid = PerlProc_getuid(); Uid_t euid = PerlProc_geteuid(); Gid_t gid = PerlProc_getgid(); @@ -4089,14 +4375,14 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) euid |= egid << 16; #endif if (uid && (euid != uid || egid != gid)) - return 1; + return 1; #endif /* !PERL_IMPLICIT_SYS */ /* This is a really primitive check; environment gets ignored only * if -T are the first chars together; otherwise one gets * "Too late" message. */ if ( argc > 1 && argv[1][0] == '-' && isALPHA_FOLD_EQ(argv[1][1], 't')) - return 1; + return 1; return 0; } @@ -4112,8 +4398,8 @@ S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ PERL_UNUSED_CONTEXT; if (flag) { - string[1] = flag; - message = string; + string[1] = flag; + message = string; } #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW @@ -4130,16 +4416,16 @@ void Perl_init_dbargs(pTHX) { AV *const args = PL_dbargs = GvAV(gv_AVadd((gv_fetchpvs("DB::args", - GV_ADDMULTI, - SVt_PVAV)))); + 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); - if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) - Perl_croak(aTHX_ "Cannot set tied @DB::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); + if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied)) + Perl_croak(aTHX_ "Cannot set tied @DB::args"); } AvREIFY_only(PL_dbargs); } @@ -4154,31 +4440,31 @@ Perl_init_debugger(pTHX) Perl_init_dbargs(aTHX); PL_DBgv = MUTABLE_GV( - SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) + SvREFCNT_inc(gv_fetchpvs("DB::DB", GV_ADDMULTI, SVt_PVGV)) ); PL_DBline = MUTABLE_GV( - SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) + SvREFCNT_inc(gv_fetchpvs("DB::dbline", GV_ADDMULTI, SVt_PVAV)) ); PL_DBsub = MUTABLE_GV(SvREFCNT_inc( - gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) + gv_HVadd(gv_fetchpvs("DB::sub", GV_ADDMULTI, SVt_PVHV)) )); PL_DBsingle = GvSV((gv_fetchpvs("DB::single", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsingle)) - sv_setiv(PL_DBsingle, 0); + sv_setiv(PL_DBsingle, 0); mg = sv_magicext(PL_DBsingle, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_SINGLE; SvSETMAGIC(PL_DBsingle); PL_DBtrace = GvSV((gv_fetchpvs("DB::trace", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBtrace)) - sv_setiv(PL_DBtrace, 0); + sv_setiv(PL_DBtrace, 0); mg = sv_magicext(PL_DBtrace, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_TRACE; SvSETMAGIC(PL_DBtrace); PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV))); if (!SvIOK(PL_DBsignal)) - sv_setiv(PL_DBsignal, 0); + sv_setiv(PL_DBsignal, 0); mg = sv_magicext(PL_DBsignal, NULL, PERL_MAGIC_debugvar, &PL_vtbl_debugvar, 0, 0); mg->mg_private = DBVARMG_SIGNAL; SvSETMAGIC(PL_DBsignal); @@ -4200,9 +4486,15 @@ Perl_init_stacks(pTHX) { SSize_t size; +#ifdef PERL_RC_STACK + const UV make_real = 1; +#else + const UV make_real = 0; +#endif /* start with 128-item stack and 8K cxstack */ - PL_curstackinfo = new_stackinfo(REASONABLE(128), - REASONABLE(8192/sizeof(PERL_CONTEXT) - 1)); + PL_curstackinfo = new_stackinfo_flags(REASONABLE(128), + REASONABLE(8192/sizeof(PERL_CONTEXT) - 1), + make_real); PL_curstackinfo->si_type = PERLSI_MAIN; #if defined DEBUGGING && !defined DEBUGGING_RE_ONLY PL_curstackinfo->si_stack_hwm = 0; @@ -4214,26 +4506,26 @@ Perl_init_stacks(pTHX) PL_stack_sp = PL_stack_base; PL_stack_max = PL_stack_base + AvMAX(PL_curstack); - Newx(PL_tmps_stack,REASONABLE(128),SV*); + Newxz(PL_tmps_stack,REASONABLE(128),SV*); PL_tmps_floor = -1; PL_tmps_ix = -1; PL_tmps_max = REASONABLE(128); - Newx(PL_markstack,REASONABLE(32),I32); + Newxz(PL_markstack, REASONABLE(32), Stack_off_t); PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + REASONABLE(32); SET_MARK_OFFSET; - Newx(PL_scopestack,REASONABLE(32),I32); + Newxz(PL_scopestack,REASONABLE(32),I32); #ifdef DEBUGGING - Newx(PL_scopestack_name,REASONABLE(32),const char*); + Newxz(PL_scopestack_name,REASONABLE(32),const char*); #endif PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); size = REASONABLE_but_at_least(128,SS_MAXPUSH); - Newx(PL_savestack, size, ANY); + Newxz(PL_savestack, size, ANY); PL_savestack_ix = 0; /*PL_savestack_max lies: it always has SS_MAXPUSH more than it claims */ PL_savestack_max = size - SS_MAXPUSH; @@ -4245,13 +4537,13 @@ STATIC void S_nuke_stacks(pTHX) { while (PL_curstackinfo->si_next) - PL_curstackinfo = PL_curstackinfo->si_next; + PL_curstackinfo = PL_curstackinfo->si_next; while (PL_curstackinfo) { - PERL_SI *p = PL_curstackinfo->si_prev; - /* curstackinfo->si_stack got nuked by sv_free_arenas() */ - Safefree(PL_curstackinfo->si_cxstack); - Safefree(PL_curstackinfo); - PL_curstackinfo = p; + PERL_SI *p = PL_curstackinfo->si_prev; + /* curstackinfo->si_stack got nuked by sv_free_arenas() */ + Safefree(PL_curstackinfo->si_cxstack); + Safefree(PL_curstackinfo); + PL_curstackinfo = p; } Safefree(PL_tmps_stack); Safefree(PL_markstack); @@ -4272,25 +4564,25 @@ Perl_populate_isa(pTHX_ const char *name, STRLEN len, ...) PERL_ARGS_ASSERT_POPULATE_ISA; if(AvFILLp(isa) != -1) - return; + 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); + 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); } @@ -4318,12 +4610,12 @@ S_init_predump_symbols(pTHX) 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); + 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); @@ -4363,37 +4655,37 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) argc--,argv++; /* skip name of script */ if (PL_doswitches) { - for (; argc > 0 && **argv == '-'; argc--,argv++) { - char *s; - if (!argv[0][1]) - break; - if (argv[0][1] == '-' && !argv[0][2]) { - argc--,argv++; - break; - } - if ((s = strchr(argv[0], '='))) { - const char *const start_name = argv[0] + 1; - sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, - TRUE, SVt_PV)), s + 1); - } - else - sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); - } + for (; argc > 0 && **argv == '-'; argc--,argv++) { + char *s; + if (!argv[0][1]) + break; + if (argv[0][1] == '-' && !argv[0][2]) { + argc--,argv++; + break; + } + if ((s = strchr(argv[0], '='))) { + const char *const start_name = argv[0] + 1; + sv_setpv(GvSV(gv_fetchpvn_flags(start_name, s - start_name, + TRUE, SVt_PV)), s + 1); + } + else + sv_setiv(GvSV(gv_fetchpv(argv[0]+1, GV_ADD, SVt_PV)),1); + } } if ((PL_argvgv = gv_fetchpvs("ARGV", GV_ADD|GV_NOTQUAL, SVt_PVAV))) { - SvREFCNT_inc_simple_void_NN(PL_argvgv); - GvMULTI_on(PL_argvgv); - av_clear(GvAVn(PL_argvgv)); - for (; argc > 0; argc--,argv++) { - SV * const sv = newSVpv(argv[0],0); - av_push(GvAV(PL_argvgv),sv); - if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { - if (PL_unicode & PERL_UNICODE_ARGV_FLAG) - SvUTF8_on(sv); - } - if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ - (void)sv_utf8_decode(sv); - } + SvREFCNT_inc_simple_void_NN(PL_argvgv); + GvMULTI_on(PL_argvgv); + av_clear(GvAVn(PL_argvgv)); + for (; argc > 0; argc--,argv++) { + SV * const sv = newSVpv(argv[0],0); + av_push(GvAV(PL_argvgv),sv); + if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { + if (PL_unicode & PERL_UNICODE_ARGV_FLAG) + SvUTF8_on(sv); + } + if (PL_unicode & PERL_UNICODE_WIDESYSCALLS_FLAG) /* Sarathy? */ + (void)sv_utf8_decode(sv); + } } if (PL_inplace && (!PL_argvgv || AvFILL(GvAV(PL_argvgv)) == -1)) @@ -4405,9 +4697,6 @@ Perl_init_argv_symbols(pTHX_ int argc, char **argv) STATIC void S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) { -#ifdef USE_ITHREADS - dVAR; -#endif GV* tmpgv; PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; @@ -4423,52 +4712,78 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) init_argv_symbols(argc,argv); if ((tmpgv = gv_fetchpvs("0", GV_ADD|GV_NOTQUAL, SVt_PV))) { - sv_setpv(GvSV(tmpgv),PL_origfilename); + sv_setpv(GvSV(tmpgv),PL_origfilename); } if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) { - HV *hv; - bool env_is_not_environ; - SvREFCNT_inc_simple_void_NN(PL_envgv); - GvMULTI_on(PL_envgv); - hv = GvHVn(PL_envgv); - hv_magic(hv, NULL, PERL_MAGIC_env); -#ifndef PERL_MICRO -#ifdef USE_ENVIRON_ARRAY - /* Note that if the supplied env parameter is actually a copy - of the global environ then it may now point to free'd memory - if the environment has been modified since. To avoid this - problem we treat env==NULL as meaning 'use the default' - */ - if (!env) - env = environ; - env_is_not_environ = env != environ; - if (env_is_not_environ + HV *hv; + bool env_is_not_environ; + SvREFCNT_inc_simple_void_NN(PL_envgv); + GvMULTI_on(PL_envgv); + hv = GvHVn(PL_envgv); + hv_magic(hv, NULL, PERL_MAGIC_env); +#if defined(USE_ENVIRON_ARRAY) || defined(WIN32) + /* Note that if the supplied env parameter is actually a copy + of the global environ then it may now point to free'd memory + if the environment has been modified since. To avoid this + problem we treat env==NULL as meaning 'use the default' + */ + if (!env) + env = environ; + env_is_not_environ = env != environ; + if (env_is_not_environ # ifdef USE_ITHREADS - && PL_curinterp == aTHX + && PL_curinterp == aTHX # endif - ) - { - environ[0] = NULL; - } - if (env) { - char *s, *old_var; - STRLEN nlen; - SV *sv; + ) + { + environ[0] = NULL; + } + if (env) { HV *dups = newHV(); + char **env_copy = env; + size_t count; - for (; *env; env++) { - old_var = *env; + while (*env_copy) { + ++env_copy; + } - if (!(s = strchr(old_var,'=')) || s == old_var) - continue; - nlen = s - old_var; + count = env_copy - env; + + if (count > PERL_HASH_DEFAULT_HvMAX) { + /* This might be an over-estimate (due to dups and other skips), + * but if so, likely it won't hurt much. + * A straw poll of login environments I have suggests that + * between 23 and 52 environment variables are typical (and no + * dups). As the default hash size is 8 buckets, expanding in + * advance saves between 2 and 3 splits in the loop below. */ + hv_ksplit(hv, count); + } + + + for (; *env; env++) { + char *old_var = *env; + char *s = strchr(old_var, '='); + STRLEN nlen; + SV *sv; + + if (!s || s == old_var) + continue; + + nlen = s - old_var; + + /* It's tempting to think that this hv_exists/hv_store pair should + * be replaced with a single hv_fetch with the LVALUE flag true. + * However, hv has magic, and if you follow the code in hv_common + * then for LVALUE fetch it recurses once, whereas exists and + * store do not recurse. Hence internally there would be no + * difference in the complexity of the code run. Moreover, all + * calls pass through "is there magic?" special case code, which + * in turn has its own #ifdef ENV_IS_CASELESS special case special + * case. Hence this code shouldn't change, as doing so won't give + * any meaningful speedup, and might well add bugs. */ -#if defined(MSDOS) && !defined(DJGPP) - *s = '\0'; - (void)strupr(old_var); - *s = '='; -#endif if (hv_exists(hv, old_var, nlen)) { + SV **dup; const char *name = savepvn(old_var, nlen); /* make sure we use the same value as getenv(), otherwise code that @@ -4477,21 +4792,21 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) sv = newSVpv(PerlEnv_getenv(name), 0); /* keep a count of the dups of this name so we can de-dup environ later */ - if (hv_exists(dups, name, nlen)) - ++SvIVX(*hv_fetch(dups, name, nlen, 0)); - else - (void)hv_store(dups, name, nlen, newSViv(1), 0); + dup = hv_fetch(dups, name, nlen, TRUE); + if (*dup) { + sv_inc(*dup); + } Safefree(name); } else { sv = newSVpv(s+1, 0); } - (void)hv_store(hv, old_var, nlen, sv, 0); - if (env_is_not_environ) - mg_set(sv); - } - if (HvKEYS(dups)) { + (void)hv_store(hv, old_var, nlen, sv, 0); + if (env_is_not_environ) + mg_set(sv); + } + if (HvTOTALKEYS(dups)) { /* environ has some duplicate definitions, remove them */ HE *entry; hv_iterinit(dups); @@ -4518,7 +4833,6 @@ S_init_postdump_symbols(pTHX_ int argc, char **argv, char **env) SvREFCNT_dec_NN(dups); } #endif /* USE_ENVIRON_ARRAY */ -#endif /* !PERL_MICRO */ } TAINT_NOT; @@ -4541,38 +4855,29 @@ S_init_perllib(pTHX) if (!TAINTING_get) { #ifndef VMS - perl5lib = PerlEnv_getenv("PERL5LIB"); -/* - * It isn't possible to delete an environment variable with - * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that - * case we treat PERL5LIB as undefined if it has a zero-length value. - */ -#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) - if (perl5lib && *perl5lib != '\0') -#else - if (perl5lib) -#endif - incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); - else { - s = PerlEnv_getenv("PERLLIB"); - if (s) - incpush_use_sep(s, 0, 0); - } + perl5lib = PerlEnv_getenv("PERL5LIB"); + if (perl5lib && *perl5lib != '\0') + incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS); + else { + s = PerlEnv_getenv("PERLLIB"); + if (s) + incpush_use_sep(s, 0, 0); + } #else /* VMS */ - /* Treat PERL5?LIB as a possible search list logical name -- the - * "natural" VMS idiom for a Unix path string. We allow each - * element to be a set of |-separated directories for compatibility. - */ - char buf[256]; - int idx = 0; - if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) - do { - incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); - } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); - else { - while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) - incpush_use_sep(buf, 0, 0); - } + /* Treat PERL5?LIB as a possible search list logical name -- the + * "natural" VMS idiom for a Unix path string. We allow each + * element to be a set of |-separated directories for compatibility. + */ + char buf[256]; + int idx = 0; + if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) + do { + incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS); + } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); + else { + while (vmstrnenv("PERLLIB",buf,idx++,NULL,0)) + incpush_use_sep(buf, 0, 0); + } #endif /* VMS */ } @@ -4580,134 +4885,24 @@ S_init_perllib(pTHX) /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC (and not the architecture specific directories from $ENV{PERL5LIB}) */ +#include "perl_inc_macro.h" /* Use the ~-expanded versions of APPLLIB (undocumented), SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB */ -#ifdef APPLLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), - INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -#endif - -#ifdef SITEARCH_EXP - /* sitearch is always relative to sitelib on Windows for - * DLL-based path intuition to work correctly */ -# if !defined(WIN32) - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITEARCH_EXP), - INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef SITELIB_EXP -# if defined(WIN32) - /* this picks up sitearch as well */ - s = PerlEnv_sitelib_path(PERL_FS_VERSION, &len); - if (s) - incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -# else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_EXP), INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef PERL_VENDORARCH_EXP - /* vendorarch is always relative to vendorlib on Windows for - * DLL-based path intuition to work correctly */ -# if !defined(WIN32) - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORARCH_EXP), - INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef PERL_VENDORLIB_EXP -# if defined(WIN32) - /* this picks up vendorarch as well */ - s = PerlEnv_vendorlib_path(PERL_FS_VERSION, &len); - if (s) - incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -# else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_EXP), - INCPUSH_CAN_RELOCATE); -# endif -#endif - -#ifdef ARCHLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(ARCHLIB_EXP), INCPUSH_CAN_RELOCATE); -#endif - -#ifndef PRIVLIB_EXP -# define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl" -#endif - -#if defined(WIN32) - s = PerlEnv_lib_path(PERL_FS_VERSION, &len); - if (s) - incpush_use_sep(s, len, INCPUSH_ADD_SUB_DIRS|INCPUSH_CAN_RELOCATE); -#elif defined(NETWARE) - S_incpush_use_sep(aTHX_ PRIVLIB_EXP, 0, INCPUSH_CAN_RELOCATE); -#else - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PRIVLIB_EXP), INCPUSH_CAN_RELOCATE); -#endif - -#ifdef PERL_OTHERLIBDIRS - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), - INCPUSH_ADD_VERSIONED_SUB_DIRS|INCPUSH_NOT_BASEDIR - |INCPUSH_CAN_RELOCATE); -#endif - - if (!TAINTING_get) { -#ifndef VMS -/* - * It isn't possible to delete an environment variable with - * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that - * case we treat PERL5LIB as undefined if it has a zero-length value. - */ -#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV) - if (perl5lib && *perl5lib != '\0') -#else - if (perl5lib) -#endif - incpush_use_sep(perl5lib, 0, - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); -#else /* VMS */ - /* Treat PERL5?LIB as a possible search list logical name -- the - * "natural" VMS idiom for a Unix path string. We allow each - * element to be a set of |-separated directories for compatibility. - */ - char buf[256]; - int idx = 0; - if (vmstrnenv("PERL5LIB",buf,0,NULL,0)) - do { - incpush_use_sep(buf, 0, - INCPUSH_ADD_OLD_VERS|INCPUSH_NOT_BASEDIR); - } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0)); -#endif /* VMS */ - } - -/* Use the ~-expanded versions of APPLLIB (undocumented), - SITELIB and VENDORLIB for older versions -*/ -#ifdef APPLLIB_EXP - S_incpush_use_sep(aTHX_ STR_WITH_LEN(APPLLIB_EXP), INCPUSH_ADD_OLD_VERS - |INCPUSH_NOT_BASEDIR|INCPUSH_CAN_RELOCATE); -#endif + INCPUSH_APPLLIB_EXP + INCPUSH_SITEARCH_EXP + INCPUSH_SITELIB_EXP + INCPUSH_PERL_VENDORARCH_EXP + INCPUSH_PERL_VENDORLIB_EXP + INCPUSH_ARCHLIB_EXP + INCPUSH_PRIVLIB_EXP + INCPUSH_PERL_OTHERLIBDIRS + INCPUSH_PERL5LIB + INCPUSH_APPLLIB_OLD_EXP + INCPUSH_SITELIB_STEM + INCPUSH_PERL_VENDORLIB_STEM + INCPUSH_PERL_OTHERLIBDIRS_ARCHONLY -#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST) - /* Search for version-specific dirs below here */ - S_incpush_use_sep(aTHX_ STR_WITH_LEN(SITELIB_STEM), - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); -#endif - - -#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST) - /* Search for version-specific dirs below here */ - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_VENDORLIB_STEM), - INCPUSH_ADD_OLD_VERS|INCPUSH_CAN_RELOCATE); -#endif - -#ifdef PERL_OTHERLIBDIRS - S_incpush_use_sep(aTHX_ STR_WITH_LEN(PERL_OTHERLIBDIRS), - INCPUSH_ADD_OLD_VERS|INCPUSH_ADD_ARCHONLY_SUB_DIRS - |INCPUSH_CAN_RELOCATE); -#endif #endif /* !PERL_IS_MINIPERL */ if (!TAINTING_get) { @@ -4719,7 +4914,7 @@ S_init_perllib(pTHX) } } -#if defined(DOSISH) || defined(__SYMBIAN32__) +#if defined(DOSISH) # define PERLLIB_SEP ';' #elif defined(__VMS) # define PERLLIB_SEP PL_perllib_sep @@ -4742,12 +4937,12 @@ S_incpush_if_exists(pTHX_ AV *const av, SV *dir, SV *const stem) PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && - S_ISDIR(tmpstatbuf.st_mode)) { - av_push(av, dir); - dir = newSVsv(stem); + S_ISDIR(tmpstatbuf.st_mode)) { + av_push(av, dir); + dir = newSVsv(stem); } else { - /* Truncate dir back to stem. */ - SvCUR_set(dir, SvCUR(stem)); + /* Truncate dir back to stem. */ + SvCUR_set(dir, SvCUR(stem)); } return dir; } @@ -4771,120 +4966,120 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) #ifdef VMS { - char *unix; + char *unix; - if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { - len = strlen(unix); - while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ - sv_usepvn(libdir,unix,len); - } - else - PerlIO_printf(Perl_error_log, - "Failed to unixify @INC element \"%s\"\n", - SvPV_nolen_const(libdir)); + if ((unix = tounixspec_ts(SvPV(libdir,len),NULL)) != NULL) { + len = strlen(unix); + while (len > 1 && unix[len-1] == '/') len--; /* Cosmetic */ + sv_usepvn(libdir,unix,len); + } + else + PerlIO_printf(Perl_error_log, + "Failed to unixify @INC element \"%s\"\n", + SvPV_nolen_const(libdir)); } #endif - /* Do the if() outside the #ifdef to avoid warnings about an unused - parameter. */ - if (canrelocate) { + /* Do the if() outside the #ifdef to avoid warnings about an unused + parameter. */ + if (canrelocate) { #ifdef PERL_RELOCATABLE_INC - /* - * Relocatable include entries are marked with a leading .../ - * - * The algorithm is - * 0: Remove that leading ".../" - * 1: Remove trailing executable name (anything after the last '/') - * from the perl path to give a perl prefix - * Then - * While the @INC element starts "../" and the prefix ends with a real - * directory (ie not . or ..) chop that real directory off the prefix - * and the leading "../" from the @INC element. ie a logical "../" - * cleanup - * Finally concatenate the prefix and the remainder of the @INC element - * The intent is that /usr/local/bin/perl and .../../lib/perl5 - * generates /usr/local/lib/perl5 - */ - const char *libpath = SvPVX(libdir); - STRLEN libpath_len = SvCUR(libdir); - if (memBEGINs(libpath, libpath_len, ".../")) { - /* Game on! */ - SV * const caret_X = get_sv("\030", 0); - /* Going to use the SV just as a scratch buffer holding a C - string: */ - SV *prefix_sv; - char *prefix; - char *lastslash; - - /* $^X is *the* source of taint if tainting is on, hence - SvPOK() won't be true. */ - assert(caret_X); - assert(SvPOKp(caret_X)); - prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), - SvUTF8(caret_X)); - /* Firstly take off the leading .../ - If all else fail we'll do the paths relative to the current - directory. */ - sv_chop(libdir, libpath + 4); - /* Don't use SvPV as we're intentionally bypassing taining, - mortal copies that the mg_get of tainting creates, and - corruption that seems to come via the save stack. - I guess that the save stack isn't correctly set up yet. */ - libpath = SvPVX(libdir); - libpath_len = SvCUR(libdir); - - prefix = SvPVX(prefix_sv); - lastslash = (char *) my_memrchr(prefix, '/', + /* + * Relocatable include entries are marked with a leading .../ + * + * The algorithm is + * 0: Remove that leading ".../" + * 1: Remove trailing executable name (anything after the last '/') + * from the perl path to give a perl prefix + * Then + * While the @INC element starts "../" and the prefix ends with a real + * directory (ie not . or ..) chop that real directory off the prefix + * and the leading "../" from the @INC element. ie a logical "../" + * cleanup + * Finally concatenate the prefix and the remainder of the @INC element + * The intent is that /usr/local/bin/perl and .../../lib/perl5 + * generates /usr/local/lib/perl5 + */ + const char *libpath = SvPVX(libdir); + STRLEN libpath_len = SvCUR(libdir); + if (memBEGINs(libpath, libpath_len, ".../")) { + /* Game on! */ + SV * const caret_X = get_sv("\030", 0); + /* Going to use the SV just as a scratch buffer holding a C + string: */ + SV *prefix_sv; + char *prefix; + char *lastslash; + + /* $^X is *the* source of taint if tainting is on, hence + SvPOK() won't be true. */ + assert(caret_X); + assert(SvPOKp(caret_X)); + prefix_sv = newSVpvn_flags(SvPVX(caret_X), SvCUR(caret_X), + SvUTF8(caret_X)); + /* Firstly take off the leading .../ + If all else fail we'll do the paths relative to the current + directory. */ + sv_chop(libdir, libpath + 4); + /* Don't use SvPV as we're intentionally bypassing taining, + mortal copies that the mg_get of tainting creates, and + corruption that seems to come via the save stack. + I guess that the save stack isn't correctly set up yet. */ + libpath = SvPVX(libdir); + libpath_len = SvCUR(libdir); + + prefix = SvPVX(prefix_sv); + lastslash = (char *) my_memrchr(prefix, '/', SvEND(prefix_sv) - prefix); - /* First time in with the *lastslash = '\0' we just wipe off - the trailing /perl from (say) /usr/foo/bin/perl - */ - if (lastslash) { - SV *tempsv; - while ((*lastslash = '\0'), /* Do that, come what may. */ + /* First time in with the *lastslash = '\0' we just wipe off + the trailing /perl from (say) /usr/foo/bin/perl + */ + if (lastslash) { + SV *tempsv; + while ((*lastslash = '\0'), /* Do that, come what may. */ ( memBEGINs(libpath, libpath_len, "../") - && (lastslash = + && (lastslash = (char *) my_memrchr(prefix, '/', SvEND(prefix_sv) - prefix)))) { - if (lastslash[1] == '\0' - || (lastslash[1] == '.' - && (lastslash[2] == '/' /* ends "/." */ - || (lastslash[2] == '/' - && lastslash[3] == '/' /* or "/.." */ - )))) { - /* Prefix ends "/" or "/." or "/..", any of which - are fishy, so don't do any more logical cleanup. - */ - break; - } - /* Remove leading "../" from path */ - libpath += 3; - libpath_len -= 3; - /* Next iteration round the loop removes the last - directory name from prefix by writing a '\0' in - the while clause. */ - } - /* prefix has been terminated with a '\0' to the correct - length. libpath points somewhere into the libdir SV. - We need to join the 2 with '/' and drop the result into - libdir. */ - tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); - SvREFCNT_dec(libdir); - /* And this is the new libdir. */ - libdir = tempsv; - if (TAINTING_get && - (PerlProc_getuid() != PerlProc_geteuid() || - PerlProc_getgid() != PerlProc_getegid())) { - /* Need to taint relocated paths if running set ID */ - SvTAINTED_on(libdir); - } - } - SvREFCNT_dec(prefix_sv); - } -#endif - } + if (lastslash[1] == '\0' + || (lastslash[1] == '.' + && (lastslash[2] == '/' /* ends "/." */ + || (lastslash[2] == '/' + && lastslash[3] == '/' /* or "/.." */ + )))) { + /* Prefix ends "/" or "/." or "/..", any of which + are fishy, so don't do any more logical cleanup. + */ + break; + } + /* Remove leading "../" from path */ + libpath += 3; + libpath_len -= 3; + /* Next iteration round the loop removes the last + directory name from prefix by writing a '\0' in + the while clause. */ + } + /* prefix has been terminated with a '\0' to the correct + length. libpath points somewhere into the libdir SV. + We need to join the 2 with '/' and drop the result into + libdir. */ + tempsv = Perl_newSVpvf(aTHX_ "%s/%s", prefix, libpath); + SvREFCNT_dec(libdir); + /* And this is the new libdir. */ + libdir = tempsv; + if (TAINTING_get && + (PerlProc_getuid() != PerlProc_geteuid() || + PerlProc_getgid() != PerlProc_getegid())) { + /* Need to taint relocated paths if running set ID */ + SvTAINTED_on(libdir); + } + } + SvREFCNT_dec(prefix_sv); + } +#endif + } return libdir; } @@ -4893,12 +5088,12 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) { #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); + = (U8)flags & (INCPUSH_ADD_VERSIONED_SUB_DIRS + |INCPUSH_ADD_ARCHONLY_SUB_DIRS|INCPUSH_ADD_OLD_VERS); const U8 add_versioned_sub_dirs - = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; + = (U8)flags & INCPUSH_ADD_VERSIONED_SUB_DIRS; const U8 add_archonly_sub_dirs - = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; + = (U8)flags & INCPUSH_ADD_ARCHONLY_SUB_DIRS; #ifdef PERL_INC_VERSION_LIST const U8 addoldvers = (U8)flags & INCPUSH_ADD_OLD_VERS; #endif @@ -4913,95 +5108,95 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags) /* Could remove this vestigial extra block, if we don't mind a lot of re-indenting diff noise. */ { - SV *const libdir = mayberelocate(dir, len, flags); - /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, - arranged to unshift #! line -I onto the front of @INC. However, - -I can add version and architecture specific libraries, and they - need to go first. The old code assumed that it was always - 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. */ + SV *const libdir = mayberelocate(dir, len, flags); + /* Change 20189146be79a0596543441fa369c6bf7f85103f, to fix RT#6665, + arranged to unshift #! line -I onto the front of @INC. However, + -I can add version and architecture specific libraries, and they + need to go first. The old code assumed that it was always + 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; - - /* - * BEFORE pushing libdir onto @INC we may first push version- and - * archname-specific sub-directories. - */ - if (using_sub_dirs) { - SV *subdir = newSVsv(libdir); + AV *const av = (using_sub_dirs) ? (unshift ? newAV() : inc) : NULL; + + /* + * BEFORE pushing libdir onto @INC we may first push version- and + * archname-specific sub-directories. + */ + if (using_sub_dirs) { + SV *subdir = newSVsv(libdir); #ifdef PERL_INC_VERSION_LIST - /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ - const char * const incverlist[] = { PERL_INC_VERSION_LIST }; - const char * const *incver; + /* Configure terminates PERL_INC_VERSION_LIST with a NULL */ + const char * const incverlist[] = { PERL_INC_VERSION_LIST }; + const char * const *incver; #endif - if (add_versioned_sub_dirs) { - /* .../version/archname if -d .../version/archname */ - sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + if (add_versioned_sub_dirs) { + /* .../version/archname if -d .../version/archname */ + sv_catpvs(subdir, "/" PERL_FS_VERSION "/" ARCHNAME); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - /* .../version if -d .../version */ - sv_catpvs(subdir, "/" PERL_FS_VERSION); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } + /* .../version if -d .../version */ + sv_catpvs(subdir, "/" PERL_FS_VERSION); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + } #ifdef PERL_INC_VERSION_LIST - if (addoldvers) { - for (incver = incverlist; *incver; incver++) { - /* .../xxx if -d .../xxx */ - Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } - } + if (addoldvers) { + for (incver = incverlist; *incver; incver++) { + /* .../xxx if -d .../xxx */ + Perl_sv_catpvf(aTHX_ subdir, "/%s", *incver); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + } + } #endif - if (add_archonly_sub_dirs) { - /* .../archname if -d .../archname */ - sv_catpvs(subdir, "/" ARCHNAME); - subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); + if (add_archonly_sub_dirs) { + /* .../archname if -d .../archname */ + sv_catpvs(subdir, "/" ARCHNAME); + subdir = S_incpush_if_exists(aTHX_ av, subdir, libdir); - } + } - assert (SvREFCNT(subdir) == 1); - SvREFCNT_dec(subdir); - } + assert (SvREFCNT(subdir) == 1); + SvREFCNT_dec(subdir); + } #endif /* !PERL_IS_MINIPERL */ - /* finally add this lib directory at the end of @INC */ - if (unshift) { + /* finally add this lib directory at the end of @INC */ + if (unshift) { #ifdef PERL_IS_MINIPERL - const Size_t extra = 0; + const Size_t extra = 0; #else - Size_t extra = av_tindex(av) + 1; + Size_t extra = av_count(av); #endif - av_unshift(inc, extra + push_basedir); - if (push_basedir) - av_store(inc, extra, libdir); + 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. - If I wanted to be naughty and wrong, I could peek inside the - implementation of av_clear(), realise that it uses - SvREFCNT_dec() too, so av's array could be a run of NULLs, - and so directly steal from it (with a memcpy() to inc, and - then memset() to NULL them out. But people copy code from the - core expecting it to be best practise, so let's use the API. - Although studious readers will note that I'm not checking any - return codes. */ - av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); - } - SvREFCNT_dec(av); -#endif - } - else if (push_basedir) { - av_push(inc, libdir); - } - - if (!push_basedir) { - assert (SvREFCNT(libdir) == 1); - SvREFCNT_dec(libdir); - } + while (extra--) { + /* av owns a reference, av_store() expects to be donated a + reference, and av expects to be sane when it's cleared. + If I wanted to be naughty and wrong, I could peek inside the + implementation of av_clear(), realise that it uses + SvREFCNT_dec() too, so av's array could be a run of NULLs, + and so directly steal from it (with a memcpy() to inc, and + then memset() to NULL them out. But people copy code from the + core expecting it to be best practise, so let's use the API. + Although studious readers will note that I'm not checking any + return codes. */ + av_store(inc, extra, SvREFCNT_inc(*av_fetch(av, extra, FALSE))); + } + SvREFCNT_dec(av); +#endif + } + else if (push_basedir) { + av_push(inc, libdir); + } + + if (!push_basedir) { + assert (SvREFCNT(libdir) == 1); + SvREFCNT_dec(libdir); + } } } @@ -5024,25 +5219,25 @@ S_incpush_use_sep(pTHX_ const char *p, STRLEN len, U32 flags) #ifndef PERL_RELOCATABLE_INCPUSH if (!len) #endif - len = strlen(p); + len = strlen(p); end = p + len; /* Break at all separators */ while ((s = (const char*)memchr(p, PERLLIB_SEP, end - p))) { - if (s == p) { - /* skip any consecutive separators */ + if (s == p) { + /* skip any consecutive separators */ - /* Uncomment the next line for PATH semantics */ - /* But you'll need to write tests */ - /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ - } else { - incpush(p, (STRLEN)(s - p), flags); - } - p = s + 1; + /* Uncomment the next line for PATH semantics */ + /* But you'll need to write tests */ + /* av_push(GvAVn(PL_incgv), newSVpvs(".")); */ + } else { + incpush(p, (STRLEN)(s - p), flags); + } + p = s + 1; } if (p != end) - incpush(p, (STRLEN)(end - p), flags); + incpush(p, (STRLEN)(end - p), flags); } @@ -5058,101 +5253,123 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PERL_ARGS_ASSERT_CALL_LIST; - while (av_tindex(paramList) >= 0) { - cv = MUTABLE_CV(av_shift(paramList)); - if (PL_savebegin) { - if (paramList == PL_beginav) { - /* save PL_beginav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); - } - else if (paramList == PL_checkav) { - /* save PL_checkav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); - } - else if (paramList == PL_unitcheckav) { - /* save PL_unitcheckav for compiler */ - Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); - } - } else { + while (av_count(paramList) > 0) { + cv = MUTABLE_CV(av_shift(paramList)); + if (PL_savebegin) { + if (paramList == PL_beginav) { + /* save PL_beginav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_beginav_save, MUTABLE_SV(cv)); + } + else if (paramList == PL_checkav) { + /* save PL_checkav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_checkav_save, MUTABLE_SV(cv)); + } + else if (paramList == PL_unitcheckav) { + /* save PL_unitcheckav for compiler */ + Perl_av_create_and_push(aTHX_ &PL_unitcheckav_save, MUTABLE_SV(cv)); + } + } else { SAVEFREESV(cv); - } - JMPENV_PUSH(ret); - switch (ret) { - case 0: - CALL_LIST_BODY(cv); - atsv = ERRSV; - (void)SvPV_const(atsv, len); - if (len) { - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - if (paramList == PL_beginav) - sv_catpvs(atsv, "BEGIN failed--compilation aborted"); - else - Perl_sv_catpvf(aTHX_ atsv, - "%s failed--call queue aborted", - paramList == PL_checkav ? "CHECK" - : paramList == PL_initav ? "INIT" - : paramList == PL_unitcheckav ? "UNITCHECK" - : "END"); - while (PL_scopestack_ix > oldscope) - LEAVE; - JMPENV_POP; - Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); - } - break; - case 1: - STATUS_ALL_FAILURE; - /* FALLTHROUGH */ - case 2: - /* my_exit() was called */ - while (PL_scopestack_ix > oldscope) - LEAVE; - FREETMPS; - SET_CURSTASH(PL_defstash); - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - JMPENV_POP; - my_exit_jump(); - NOT_REACHED; /* NOTREACHED */ - case 3: - if (PL_restartop) { - PL_curcop = &PL_compiling; - CopLINE_set(PL_curcop, oldline); - JMPENV_JUMP(3); - } - PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); - FREETMPS; - break; - } - JMPENV_POP; + } + JMPENV_PUSH(ret); + switch (ret) { + case 0: + CALL_LIST_BODY(cv); + atsv = ERRSV; + (void)SvPV_const(atsv, len); + if (len) { + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + if (paramList == PL_beginav) + sv_catpvs(atsv, "BEGIN failed--compilation aborted"); + else + Perl_sv_catpvf(aTHX_ atsv, + "%s failed--call queue aborted", + paramList == PL_checkav ? "CHECK" + : paramList == PL_initav ? "INIT" + : paramList == PL_unitcheckav ? "UNITCHECK" + : "END"); + while (PL_scopestack_ix > oldscope) + LEAVE; + JMPENV_POP; + Perl_croak(aTHX_ "%" SVf, SVfARG(atsv)); + } + break; + case 1: + STATUS_ALL_FAILURE; + /* FALLTHROUGH */ + case 2: + /* my_exit() was called */ + while (PL_scopestack_ix > oldscope) + LEAVE; + FREETMPS; + SET_CURSTASH(PL_defstash); + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + JMPENV_POP; + my_exit_jump(); + NOT_REACHED; /* NOTREACHED */ + case 3: + if (PL_restartop) { + PL_curcop = &PL_compiling; + CopLINE_set(PL_curcop, oldline); + JMPENV_JUMP(3); + } + PerlIO_printf(Perl_error_log, "panic: restartop in call_list\n"); + FREETMPS; + break; + } + JMPENV_POP; } } +/* +=for apidoc my_exit + +A wrapper for the C library L, honoring what L +say to do. + +=cut +*/ + void Perl_my_exit(pTHX_ U32 status) { if (PL_exit_flags & PERL_EXIT_ABORT) { - abort(); + abort(); } if (PL_exit_flags & PERL_EXIT_WARN) { - PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); - PL_exit_flags &= ~PERL_EXIT_ABORT; + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit %lu", (unsigned long)status); + PL_exit_flags &= ~PERL_EXIT_ABORT; } switch (status) { case 0: - STATUS_ALL_SUCCESS; - break; + STATUS_ALL_SUCCESS; + break; case 1: - STATUS_ALL_FAILURE; - break; + STATUS_ALL_FAILURE; + break; default: - STATUS_EXIT_SET(status); - break; + STATUS_EXIT_SET(status); + break; } my_exit_jump(); } +/* +=for apidoc my_failure_exit + +Exit the running Perl process with an error. + +On non-VMS platforms, this is essentially equivalent to L>, using +C, but forces an en error code of 255 if C is 0. + +On VMS, it takes care to set the appropriate severity bits in the exit status. + +=cut +*/ + void Perl_my_failure_exit(pTHX) { @@ -5169,79 +5386,80 @@ Perl_my_failure_exit(pTHX) /* According to the die_exit.t tests, if errno is non-zero */ /* It should be used for the error status. */ - if (errno == EVMSERR) { - STATUS_NATIVE = vaxc$errno; - } else { + if (errno == EVMSERR) { + STATUS_NATIVE = vaxc$errno; + } else { /* According to die_exit.t tests, if the child_exit code is */ /* also zero, then we need to exit with a code of 255 */ if ((errno != 0) && (errno < 256)) - STATUS_UNIX_EXIT_SET(errno); + STATUS_UNIX_EXIT_SET(errno); else if (STATUS_UNIX < 255) { - STATUS_UNIX_EXIT_SET(255); + STATUS_UNIX_EXIT_SET(255); } - } - - /* The exit code could have been set by $? or vmsish which - * means that it may not have fatal set. So convert - * success/warning codes to fatal with out changing - * the POSIX status code. The severity makes VMS native - * status handling work, while UNIX mode programs use the - * the POSIX exit codes. - */ - if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { - STATUS_NATIVE &= STS$M_COND_ID; - STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; + } + + /* The exit code could have been set by $? or vmsish which + * means that it may not have fatal set. So convert + * success/warning codes to fatal with out changing + * the POSIX status code. The severity makes VMS native + * status handling work, while UNIX mode programs use the + * POSIX exit codes. + */ + if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0) { + STATUS_NATIVE &= STS$M_COND_ID; + STATUS_NATIVE |= STS$K_ERROR | STS$M_INHIB_MSG; } } else { - /* Traditionally Perl on VMS always expects a Fatal Error. */ - if (vaxc$errno & 1) { - - /* So force success status to failure */ - if (STATUS_NATIVE & 1) - STATUS_ALL_FAILURE; - } - else { - if (!vaxc$errno) { - STATUS_UNIX = EINTR; /* In case something cares */ - STATUS_ALL_FAILURE; - } - else { - int severity; - STATUS_NATIVE = vaxc$errno; /* Should already be this */ - - /* Encode the severity code */ - severity = STATUS_NATIVE & STS$M_SEVERITY; - STATUS_UNIX = (severity ? severity : 1) << 8; - - /* Perl expects this to be a fatal error */ - if (severity != STS$K_SEVERE) - STATUS_ALL_FAILURE; - } - } + /* Traditionally Perl on VMS always expects a Fatal Error. */ + if (vaxc$errno & 1) { + + /* So force success status to failure */ + if (STATUS_NATIVE & 1) + STATUS_ALL_FAILURE; + } + else { + if (!vaxc$errno) { + STATUS_UNIX = EINTR; /* In case something cares */ + STATUS_ALL_FAILURE; + } + else { + int severity; + STATUS_NATIVE = vaxc$errno; /* Should already be this */ + + /* Encode the severity code */ + severity = STATUS_NATIVE & STS$M_SEVERITY; + STATUS_UNIX = (severity ? severity : 1) << 8; + + /* Perl expects this to be a fatal error */ + if (severity != STS$K_SEVERE) + STATUS_ALL_FAILURE; + } + } } #else int exitstatus; - if (errno & 255) - STATUS_UNIX_SET(errno); + int eno = errno; + if (eno & 255) + STATUS_UNIX_SET(eno); else { - exitstatus = STATUS_UNIX >> 8; - if (exitstatus & 255) - STATUS_UNIX_SET(exitstatus); - else - STATUS_UNIX_SET(255); + exitstatus = STATUS_UNIX >> 8; + if (exitstatus & 255) + STATUS_UNIX_SET(exitstatus); + else + STATUS_UNIX_SET(255); } #endif if (PL_exit_flags & PERL_EXIT_ABORT) { - abort(); + abort(); } if (PL_exit_flags & PERL_EXIT_WARN) { - PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ - Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); - PL_exit_flags &= ~PERL_EXIT_ABORT; + PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */ + Perl_warn(aTHX_ "Unexpected exit failure %ld", (long)PL_statusvalue); + PL_exit_flags &= ~PERL_EXIT_ABORT; } my_exit_jump(); } @@ -5250,15 +5468,15 @@ STATIC void S_my_exit_jump(pTHX) { if (PL_e_script) { - SvREFCNT_dec(PL_e_script); - PL_e_script = NULL; + SvREFCNT_dec(PL_e_script); + PL_e_script = NULL; } POPSTACK_TO(PL_mainstack); if (cxstack_ix >= 0) { dounwind(-1); - cx_popblock(cxstack); } + rpp_obliterate_stack_to(0); LEAVE_SCOPE(0); JMPENV_JUMP(2); @@ -5268,15 +5486,16 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { const char * const p = SvPVX_const(PL_e_script); - const char *nl = strchr(p, '\n'); + const char * const e = SvEND(PL_e_script); + const char *nl = (char *) memchr(p, '\n', e - p); PERL_UNUSED_ARG(idx); PERL_UNUSED_ARG(maxlen); - nl = (nl) ? nl+1 : SvEND(PL_e_script); + nl = (nl) ? nl+1 : e; if (nl-p == 0) { - filter_del(read_e_script); - return 0; + filter_del(read_e_script); + return 0; } sv_catpvn(buf_sv, p, nl-p); sv_chop(PL_e_script, nl); @@ -5285,10 +5504,10 @@ read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) /* removes boilerplate code at the end of each boot_Module xsub */ void -Perl_xs_boot_epilog(pTHX_ const I32 ax) +Perl_xs_boot_epilog(pTHX_ const SSize_t ax) { if (PL_unitcheckav) - call_list(PL_scopestack_ix, PL_unitcheckav); + call_list(PL_scopestack_ix, PL_unitcheckav); XSRETURN_YES; }