X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6c9570dc5de7137a22f5d4e76431529d4f7342b7..cb4a303650e05576b6797aaca1373576a2f37af7:/util.c diff --git a/util.c b/util.c index 360ec28..ef0970e 100644 --- a/util.c +++ b/util.c @@ -1,7 +1,7 @@ /* util.c * - * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, + * 2002, 2003, 2004, 2005, 2006, 2007, 2008 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. @@ -9,8 +9,10 @@ */ /* - * "Very useful, no doubt, that was to Saruman; yet it seems that he was - * not content." --Gandalf + * 'Very useful, no doubt, that was to Saruman; yet it seems that he was + * not content.' --Gandalf to Pippin + * + * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* This file contains assorted utility routines. @@ -178,11 +180,11 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) ptr = (Malloc_t)PerlMem_realloc(where,size); PERL_ALLOC_CHECK(ptr); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); - - if (ptr != NULL) { + /* MUST do this fixup first, before doing ANYTHING else, as anything else + might allocate memory/free/move memory, and until we do the fixup, it + may well be chasing (and writing to) free memory. */ #ifdef PERL_TRACK_MEMPOOL + if (ptr != NULL) { struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; @@ -198,7 +200,17 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) header->prev->next = header; ptr = (Malloc_t)((char*)ptr+sTHX); + } #endif + + /* In particular, must do that fixup above before logging anything via + *printf(), as it can reallocate memory, which can cause SEGVs. */ + + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); + + + if (ptr != NULL) { return ptr; } else if (PL_nomemok) @@ -258,11 +270,23 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) { dTHX; Malloc_t ptr; + MEM_SIZE total_size = 0; + /* Even though calloc() for zero bytes is strange, be robust. */ + if (size && (count <= MEM_SIZE_MAX / size)) + total_size = size * count; + else + Perl_croak_nocontext("%s", PL_memory_wrap); +#ifdef PERL_TRACK_MEMPOOL + if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) + total_size += sTHX; + else + Perl_croak_nocontext("%s", PL_memory_wrap); +#endif #ifdef HAS_64K_LIMIT - if (size * count > 0xffff) { + if (total_size > 0xffff) { PerlIO_printf(Perl_error_log, - "Allocation too large: %lx\n", size * count) FLUSH; + "Allocation too large: %lx\n", total_size) FLUSH; my_exit(1); } #endif /* HAS_64K_LIMIT */ @@ -270,20 +294,28 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) if ((long)size < 0 || (long)count < 0) Perl_croak_nocontext("panic: calloc"); #endif - size *= count; #ifdef PERL_TRACK_MEMPOOL - size += sTHX; + /* Have to use malloc() because we've added some space for our tracking + header. */ + /* malloc(0) is non-portable. */ + ptr = (Malloc_t)PerlMem_malloc(total_size ? total_size : 1); +#else + /* Use calloc() because it might save a memset() if the memory is fresh + and clean from the OS. */ + if (count && size) + ptr = (Malloc_t)PerlMem_calloc(count, size); + else /* calloc(0) is non-portable. */ + ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); #endif - ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size)); if (ptr != NULL) { - memset((void*)ptr, 0, size); #ifdef PERL_TRACK_MEMPOOL { struct perl_memory_debug_header *const header = (struct perl_memory_debug_header *)ptr; + memset((void*)ptr, 0, total_size); header->interpreter = aTHX; /* Link us into the list. */ header->prev = &PL_memory_debug_header; @@ -291,7 +323,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) PL_memory_debug_header.next = header; header->next->prev = header; # ifdef PERL_POISON - header->size = size; + header->size = total_size; # endif ptr = (Malloc_t)((char*)ptr+sTHX); } @@ -337,10 +369,11 @@ Free_t Perl_mfree (Malloc_t where) /* copy a string up to some (non-backslashed) delimiter, if any */ char * -Perl_delimcpy(pTHX_ register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) +Perl_delimcpy(register char *to, register const char *toend, register const char *from, register const char *fromend, register int delim, I32 *retlen) { register I32 tolen; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_DELIMCPY; for (tolen = 0; from < fromend; from++, tolen++) { if (*from == '\\') { @@ -366,10 +399,11 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons /* This routine was donated by Corey Satten. */ char * -Perl_instr(pTHX_ register const char *big, register const char *little) +Perl_instr(register const char *big, register const char *little) { register I32 first; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_INSTR; if (!little) return (char*)big; @@ -399,24 +433,24 @@ Perl_instr(pTHX_ register const char *big, register const char *little) /* same as instr but allow embedded nulls */ char * -Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) +Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) { - PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_NINSTR; if (little >= lend) return (char*)big; { - char first = *little++; + const char first = *little; const char *s, *x; - bigend -= lend - little; + bigend -= lend - little++; OUTER: while (big <= bigend) { - if (*big++ != first) - goto OUTER; - for (x=big,s=little; s < lend; x++,s++) { - if (*s != *x) - goto OUTER; + if (*big++ == first) { + for (x=big,s=little; s < lend; x++,s++) { + if (*s != *x) + goto OUTER; + } + return (char*)(big-1); } - return (char*)(big-1); } } return NULL; @@ -425,12 +459,13 @@ Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const /* reverse of the above--find last substring */ char * -Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend) +Perl_rninstr(register const char *big, const char *bigend, const char *little, const char *lend) { register const char *bigbeg; register const I32 first = *little; register const char * const littleend = lend; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_RNINSTR; if (little >= littleend) return (char*)bigend; @@ -481,6 +516,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) U32 rarest = 0; U32 frequency = 256; + PERL_ARGS_ASSERT_FBM_COMPILE; + if (flags & FBMcf_TAIL) { MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; sv_catpvs(sv, "\n"); /* Taken into account in fbm_instr() */ @@ -504,7 +541,6 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET); s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */ memset((void*)table, mlen, 256); - BmFLAGS(sv) = (U8)flags; i = 0; sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { @@ -524,6 +560,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) frequency = PL_freq[s[i]]; } } + BmFLAGS(sv) = (U8)flags; BmRARE(sv) = s[rarest]; BmPREVIOUS(sv) = rarest; BmUSEFUL(sv) = 100; /* Initial value */ @@ -558,6 +595,8 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register STRLEN littlelen = l; register const I32 multiline = flags & FBMrf_MULTILINE; + PERL_ARGS_ASSERT_FBM_INSTR; + if ((STRLEN)(bigend - big) < littlelen) { if ( SvTAIL(littlestr) && ((STRLEN)(bigend - big) == littlelen - 1) @@ -761,6 +800,8 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift register const unsigned char *littleend; I32 found = 0; + PERL_ARGS_ASSERT_SCREAMINSTR; + assert(SvTYPE(littlestr) == SVt_PVGV); assert(SvVALID(littlestr)); @@ -769,7 +810,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { cant_find: if ( BmRARE(littlestr) == '\n' - && BmPREVIOUS(littlestr) == (U8)SvCUR(littlestr) - 1) { + && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { little = (const unsigned char *)(SvPVX_const(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; @@ -838,11 +879,12 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } I32 -Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_ibcmp(const char *s1, const char *s2, register I32 len) { register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_IBCMP; while (len--) { if (*a != *b && *a != PL_fold[*b]) @@ -853,12 +895,13 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) } I32 -Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) +Perl_ibcmp_locale(const char *s1, const char *s2, register I32 len) { dVAR; register const U8 *a = (const U8 *)s1; register const U8 *b = (const U8 *)s2; - PERL_UNUSED_CONTEXT; + + PERL_ARGS_ASSERT_IBCMP_LOCALE; while (len--) { if (*a != *b && *a != PL_fold_locale[*b]) @@ -953,6 +996,29 @@ Perl_savesharedpv(pTHX_ const char *pv) } /* +=for apidoc savesharedpvn + +A version of C which allocates the duplicate string in memory +which is shared between threads. (With the specific difference that a NULL +pointer is not acceptable) + +=cut +*/ +char * +Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) +{ + char *const newaddr = (char*)PerlMemShared_malloc(len + 1); + + PERL_ARGS_ASSERT_SAVESHAREDPVN; + + if (!newaddr) { + return write_no_mem(); + } + newaddr[len] = '\0'; + return (char*)memcpy(newaddr, pv, len); +} + +/* =for apidoc savesvpv A version of C/C which gets the string to duplicate from @@ -968,6 +1034,8 @@ Perl_savesvpv(pTHX_ SV *sv) const char * const pv = SvPV_const(sv, len); register char *newaddr; + PERL_ARGS_ASSERT_SAVESVPV; + ++len; Newx(newaddr,len,char); return (char *) CopyD(pv,newaddr,len,char); @@ -984,7 +1052,7 @@ S_mess_alloc(pTHX) XPVMG *any; if (!PL_dirty) - return sv_2mortal(newSVpvs("")); + return newSVpvs_flags("", SVs_TEMP); if (PL_mess_sv) return PL_mess_sv; @@ -1007,6 +1075,7 @@ Perl_form_nocontext(const char* pat, ...) dTHX; char *retval; va_list args; + PERL_ARGS_ASSERT_FORM_NOCONTEXT; va_start(args, pat); retval = vform(pat, &args); va_end(args); @@ -1039,6 +1108,7 @@ Perl_form(pTHX_ const char* pat, ...) { char *retval; va_list args; + PERL_ARGS_ASSERT_FORM; va_start(args, pat); retval = vform(pat, &args); va_end(args); @@ -1049,6 +1119,7 @@ char * Perl_vform(pTHX_ const char *pat, va_list *args) { SV * const sv = mess_alloc(); + PERL_ARGS_ASSERT_VFORM; sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); return SvPVX(sv); } @@ -1060,6 +1131,7 @@ Perl_mess_nocontext(const char *pat, ...) dTHX; SV *retval; va_list args; + PERL_ARGS_ASSERT_MESS_NOCONTEXT; va_start(args, pat); retval = vmess(pat, &args); va_end(args); @@ -1072,6 +1144,7 @@ Perl_mess(pTHX_ const char *pat, ...) { SV *retval; va_list args; + PERL_ARGS_ASSERT_MESS; va_start(args, pat); retval = vmess(pat, &args); va_end(args); @@ -1084,6 +1157,8 @@ S_closest_cop(pTHX_ const COP *cop, const OP *o) dVAR; /* Look for PL_op starting from o. cop is the last COP we've seen. */ + PERL_ARGS_ASSERT_CLOSEST_COP; + if (!o || o == PL_op) return cop; @@ -1117,6 +1192,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) dVAR; SV * const sv = mess_alloc(); + PERL_ARGS_ASSERT_VMESS; + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { /* @@ -1133,7 +1210,10 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, OutCopFILE(cop), (IV)CopLINE(cop)); - if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { + /* Seems that GvIO() can be untrustworthy during global destruction. */ + if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) + && IoLINES(GvIOp(PL_last_in_gv))) + { const bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, @@ -1149,15 +1229,17 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) } void -Perl_write_to_stderr(pTHX_ const char* message, int msglen) +Perl_write_to_stderr(pTHX_ SV* msv) { dVAR; IO *io; MAGIC *mg; + PERL_ARGS_ASSERT_WRITE_TO_STDERR; + if (PL_stderrgv && SvREFCNT(PL_stderrgv) && (io = GvIO(PL_stderrgv)) - && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) + && (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar))) { dSP; ENTER; @@ -1171,8 +1253,8 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); - PUSHs(SvTIED_obj((SV*)io, mg)); - PUSHs(sv_2mortal(newSVpvn(message, msglen))); + PUSHs(SvTIED_obj(MUTABLE_SV(io), mg)); + PUSHs(msv); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1183,14 +1265,16 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) else { #ifdef USE_SFIO /* SFIO can really mess with your errno */ - const int e = errno; + dSAVED_ERRNO; #endif PerlIO * const serr = Perl_error_log; + STRLEN msglen; + const char* message = SvPVx_const(msv, msglen); PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO - errno = e; + RESTORE_ERRNO; #endif } } @@ -1198,7 +1282,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) /* Common code used by vcroak, vdie, vwarn and vwarner */ STATIC bool -S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) +S_vdie_common(pTHX_ SV *message, bool warn) { dVAR; HV *stash; @@ -1226,8 +1310,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) *hook = NULL; } if (warn || message) { - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; + msg = newSVsv(message); SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1239,7 +1322,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) PUSHMARK(SP); XPUSHs(msg); PUTBACK; - call_sv((SV*)cv, G_DISCARD); + call_sv(MUTABLE_SV(cv), G_DISCARD); POPSTACK; LEAVE; return TRUE; @@ -1247,60 +1330,43 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) return FALSE; } -STATIC const char * -S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, - I32* utf8) +STATIC SV * +S_vdie_croak_common(pTHX_ const char* pat, va_list* args) { dVAR; - const char *message; + SV *message; if (pat) { SV * const msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); - message = SvPV_const(PL_errors, *msglen); + message = sv_mortalcopy(PL_errors); SvCUR_set(PL_errors, 0); } else - message = SvPV_const(msv,*msglen); - *utf8 = SvUTF8(msv); + message = msv; } else { message = NULL; } - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die/croak: message = %s\ndiehook = %p\n", - (void*)thr, message, (void*)PL_diehook)); if (PL_diehook) { - S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); + S_vdie_common(aTHX_ message, FALSE); } return message; } -OP * -Perl_vdie(pTHX_ const char* pat, va_list *args) +static OP * +S_vdie(pTHX_ const char* pat, va_list *args) { dVAR; - const char *message; - const int was_in_eval = PL_in_eval; - STRLEN msglen; - I32 utf8 = 0; - - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: curstack = %p, mainstack = %p\n", - (void*)thr, (void*)PL_curstack, (void*)PL_mainstack)); + SV *message; - message = vdie_croak_common(pat, args, &msglen, &utf8); + message = vdie_croak_common(pat, args); - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", - (void*)thr, (void*)PL_restartop, was_in_eval, (void*)PL_top_env)); - if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) - JMPENV_JUMP(3); - return PL_restartop; + die_where(message); + /* NOTREACHED */ + return NULL; } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1332,22 +1398,11 @@ void Perl_vcroak(pTHX_ const char* pat, va_list *args) { dVAR; - const char *message; - STRLEN msglen; - I32 utf8 = 0; - - message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); + SV *msv; - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); - } - else if (!message) - message = SvPVx_const(ERRSV, msglen); + msv = S_vdie_croak_common(aTHX_ pat, args); - write_to_stderr(message, msglen); - my_failure_exit(); + die_where(msv); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1376,7 +1431,7 @@ sidestepping the normal C order of execution. See C. If you want to throw an exception object, assign the object to C<$@> and then pass C to croak(): - errsv = get_sv("@", TRUE); + errsv = get_sv("@", GV_ADD); sv_setsv(errsv, exception_object); croak(NULL); @@ -1397,17 +1452,16 @@ void Perl_vwarn(pTHX_ const char* pat, va_list *args) { dVAR; - STRLEN msglen; SV * const msv = vmess(pat, args); - const I32 utf8 = SvUTF8(msv); - const char * const message = SvPV_const(msv, msglen); + + PERL_ARGS_ASSERT_VWARN; if (PL_warnhook) { - if (vdie_common(message, msglen, utf8, TRUE)) + if (vdie_common(msv, TRUE)) return; } - write_to_stderr(message, msglen); + write_to_stderr(msv); } #if defined(PERL_IMPLICIT_CONTEXT) @@ -1416,6 +1470,7 @@ Perl_warn_nocontext(const char *pat, ...) { dTHX; va_list args; + PERL_ARGS_ASSERT_WARN_NOCONTEXT; va_start(args, pat); vwarn(pat, &args); va_end(args); @@ -1435,6 +1490,7 @@ void Perl_warn(pTHX_ const char *pat, ...) { va_list args; + PERL_ARGS_ASSERT_WARN; va_start(args, pat); vwarn(pat, &args); va_end(args); @@ -1446,6 +1502,7 @@ Perl_warner_nocontext(U32 err, const char *pat, ...) { dTHX; va_list args; + PERL_ARGS_ASSERT_WARNER_NOCONTEXT; va_start(args, pat); vwarner(err, pat, &args); va_end(args); @@ -1453,9 +1510,36 @@ Perl_warner_nocontext(U32 err, const char *pat, ...) #endif /* PERL_IMPLICIT_CONTEXT */ void +Perl_ck_warner_d(pTHX_ U32 err, const char* pat, ...) +{ + PERL_ARGS_ASSERT_CK_WARNER_D; + + if (Perl_ckwarn_d(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} + +void +Perl_ck_warner(pTHX_ U32 err, const char* pat, ...) +{ + PERL_ARGS_ASSERT_CK_WARNER; + + if (Perl_ckwarn(aTHX_ err)) { + va_list args; + va_start(args, pat); + vwarner(err, pat, &args); + va_end(args); + } +} + +void Perl_warner(pTHX_ U32 err, const char* pat,...) { va_list args; + PERL_ARGS_ASSERT_WARNER; va_start(args, pat); vwarner(err, pat, &args); va_end(args); @@ -1465,23 +1549,15 @@ void Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) { dVAR; + PERL_ARGS_ASSERT_VWARNER; if (PL_warnhook == PERL_WARNHOOK_FATAL || ckDEAD(err)) { SV * const msv = vmess(pat, args); - STRLEN msglen; - const char * const message = SvPV_const(msv, msglen); - const I32 utf8 = SvUTF8(msv); if (PL_diehook) { - assert(message); - S_vdie_common(aTHX_ message, msglen, utf8, FALSE); - } - if (PL_in_eval) { - PL_restartop = die_where(message, msglen); - SvFLAGS(ERRSV) |= utf8; - JMPENV_JUMP(3); + assert(msv); + S_vdie_common(aTHX_ msv, FALSE); } - write_to_stderr(message, msglen); - my_failure_exit(); + die_where(msv); } else { Perl_vwarn(aTHX_ pat, args); @@ -1494,26 +1570,11 @@ bool Perl_ckwarn(pTHX_ U32 w) { dVAR; - return - ( - isLEXWARN_on - && PL_curcop->cop_warnings != pWARN_NONE - && ( - PL_curcop->cop_warnings == pWARN_ALL - || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) - || (unpackWARN2(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) - || (unpackWARN3(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) - || (unpackWARN4(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) - ) - ) - || - ( - isLEXWARN_off && PL_dowarn & G_WARN_ON - ) - ; + /* If lexical warnings have not been set, use $^W. */ + if (isLEXWARN_off) + return PL_dowarn & G_WARN_ON; + + return ckwarn_common(w); } /* implements the ckWARN?_d macro */ @@ -1522,22 +1583,42 @@ bool Perl_ckwarn_d(pTHX_ U32 w) { dVAR; - return - isLEXWARN_off - || PL_curcop->cop_warnings == pWARN_ALL - || ( - PL_curcop->cop_warnings != pWARN_NONE - && ( - isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) - || (unpackWARN2(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) - || (unpackWARN3(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) - || (unpackWARN4(w) && - isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) - ) - ) - ; + /* If lexical warnings have not been set then default classes warn. */ + if (isLEXWARN_off) + return TRUE; + + return ckwarn_common(w); +} + +static bool +S_ckwarn_common(pTHX_ U32 w) +{ + if (PL_curcop->cop_warnings == pWARN_ALL) + return TRUE; + + if (PL_curcop->cop_warnings == pWARN_NONE) + return FALSE; + + /* Check the assumption that at least the first slot is non-zero. */ + assert(unpackWARN1(w)); + + /* Check the assumption that it is valid to stop as soon as a zero slot is + seen. */ + if (!unpackWARN2(w)) { + assert(!unpackWARN3(w)); + assert(!unpackWARN4(w)); + } else if (!unpackWARN3(w)) { + assert(!unpackWARN4(w)); + } + + /* Right, dealt with all the special cases, which are implemented as non- + pointers, so there is a pointer to a real warnings mask. */ + do { + if (isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w))) + return TRUE; + } while (w >>= WARNshift); + + return FALSE; } /* Set buffer=NULL to get a new one. */ @@ -1546,6 +1627,7 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size) { const MEM_SIZE len_wanted = sizeof(STRLEN) + size; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; buffer = (STRLEN*) (specialWARN(buffer) ? @@ -1581,9 +1663,16 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #ifndef PERL_USE_SAFE_PUTENV if (!PL_use_safe_putenv) { /* most putenv()s leak, so we manipulate environ directly */ - register I32 i=setenv_getix(nam); /* where does it go? */ + register I32 i; + register const I32 len = strlen(nam); int nlen, vlen; + /* where does it go? */ + for (i = 0; environ[i]; i++) { + if (strnEQ(environ[i],nam,len) && environ[i][len] == '=') + break; + } + if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; I32 max; @@ -1687,28 +1776,6 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) #endif /* WIN32 || NETWARE */ -#ifndef PERL_MICRO -I32 -Perl_setenv_getix(pTHX_ const char *nam) -{ - register I32 i; - register const I32 len = strlen(nam); - PERL_UNUSED_CONTEXT; - - for (i = 0; environ[i]; i++) { - if ( -#ifdef WIN32 - strnicmp(environ[i],nam,len) == 0 -#else - strnEQ(environ[i],nam,len) -#endif - && environ[i][len] == '=') - break; /* strnEQ must come first to avoid */ - } /* potential SEGV's */ - return i; -} -#endif /* !PERL_MICRO */ - #endif /* !VMS && !EPOC*/ #ifdef UNLINK_ALL_VERSIONS @@ -1717,6 +1784,8 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ { I32 retries = 0; + PERL_ARGS_ASSERT_UNLNK; + while (PerlLIO_unlink(f) >= 0) retries++; return retries ? 0 : -1; @@ -1730,6 +1799,8 @@ Perl_my_bcopy(register const char *from,register char *to,register I32 len) { char * const retval = to; + PERL_ARGS_ASSERT_MY_BCOPY; + if (from - to >= 0) { while (len--) *to++ = *from++; @@ -1751,6 +1822,8 @@ Perl_my_memset(register char *loc, register I32 ch, register I32 len) { char * const retval = loc; + PERL_ARGS_ASSERT_MY_MEMSET; + while (len--) *loc++ = ch; return retval; @@ -1764,6 +1837,8 @@ Perl_my_bzero(register char *loc, register I32 len) { char * const retval = loc; + PERL_ARGS_ASSERT_MY_BZERO; + while (len--) *loc++ = 0; return retval; @@ -1779,6 +1854,8 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len) register const U8 *b = (const U8 *)s2; register I32 tmp; + PERL_ARGS_ASSERT_MY_MEMCMP; + while (len--) { if ((tmp = *a++ - *b++)) return tmp; @@ -1788,24 +1865,51 @@ Perl_my_memcmp(const char *s1, const char *s2, register I32 len) #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */ #ifndef HAS_VPRINTF +/* This vsprintf replacement should generally never get used, since + vsprintf was available in both System V and BSD 2.11. (There may + be some cross-compilation or embedded set-ups where it is needed, + however.) + + If you encounter a problem in this function, it's probably a symptom + that Configure failed to detect your system's vprintf() function. + See the section on "item vsprintf" in the INSTALL file. + + This version may compile on systems with BSD-ish , + but probably won't on others. +*/ #ifdef USE_CHAR_VSPRINTF char * #else int #endif -vsprintf(char *dest, const char *pat, char *args) +vsprintf(char *dest, const char *pat, void *args) { FILE fakebuf; +#if defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) + FILE_ptr(&fakebuf) = (STDCHAR *) dest; + FILE_cnt(&fakebuf) = 32767; +#else + /* These probably won't compile -- If you really need + this, you'll have to figure out some other method. */ fakebuf._ptr = dest; fakebuf._cnt = 32767; +#endif #ifndef _IOSTRG #define _IOSTRG 0 #endif fakebuf._flag = _IOWRT|_IOSTRG; _doprnt(pat, args, &fakebuf); /* what a kludge */ - (void)putc('\0', &fakebuf); +#if defined(STDIO_PTR_LVALUE) + *(FILE_ptr(&fakebuf)++) = '\0'; +#else + /* PerlIO has probably #defined away fputc, but we want it here. */ +# ifdef fputc +# undef fputc /* XXX Should really restore it later */ +# endif + (void)fputc('\0', &fakebuf); +#endif #ifdef USE_CHAR_VSPRINTF return(dest); #else @@ -1838,7 +1942,10 @@ Perl_my_htonl(pTHX_ long l) char c[sizeof(long)]; } u; -#if BYTEORDER == 0x1234 +#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678 +#if BYTEORDER == 0x12345678 + u.result = 0; +#endif u.c[0] = (l >> 24) & 255; u.c[1] = (l >> 16) & 255; u.c[2] = (l >> 8) & 255; @@ -2132,6 +2239,8 @@ Perl_my_swabn(void *ptr, int n) register char *e = s + (n-1); register char tc; + PERL_ARGS_ASSERT_MY_SWABN; + for (n /= 2; n > 0; s++, e--, n--) { tc = *s; *s = *e; @@ -2140,9 +2249,9 @@ Perl_my_swabn(void *ptr, int n) } PerlIO * -Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) +Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) { -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) && !defined(NETWARE) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) dVAR; int p[2]; register I32 This, that; @@ -2151,6 +2260,8 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) I32 did_pipes = 0; int pp[2]; + PERL_ARGS_ASSERT_MY_POPEN_LIST; + PERL_FLUSHALL_FOR_CHILD; This = (*mode == 'w'); that = !This; @@ -2173,6 +2284,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) } return NULL; } + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2230,9 +2342,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) else PerlLIO_close(p[that]); /* close child's end of pipe */ - LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); - UNLOCK_FDPID_MUTEX; SvUPGRADE(sv,SVt_IV); SvIV_set(sv, pid); PL_forkprocess = pid; @@ -2269,7 +2379,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) return PerlIO_fdopen(p[This], mode); #else # ifdef OS2 /* Same, without fork()ing and all extra overhead... */ - return my_syspopen4(aTHX_ Nullch, mode, n, args); + return my_syspopen4(aTHX_ NULL, mode, n, args); # else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; @@ -2278,7 +2388,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) } /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { @@ -2291,6 +2401,8 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) I32 did_pipes = 0; int pp[2]; + PERL_ARGS_ASSERT_MY_POPEN; + PERL_FLUSHALL_FOR_CHILD; #ifdef OS2 if (doexec) { @@ -2316,9 +2428,10 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) PerlLIO_close(pp[1]); } if (!doexec) - Perl_croak(aTHX_ "Can't fork"); + Perl_croak(aTHX_ "Can't fork: %s", Strerror(errno)); return NULL; } + Perl_ck_warner(aTHX_ packWARN(WARN_PIPE), "Can't fork, trying again in 5 seconds"); sleep(5); } if (pid == 0) { @@ -2396,9 +2509,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) else PerlLIO_close(p[that]); - LOCK_FDPID_MUTEX; sv = *av_fetch(PL_fdpid,p[This],TRUE); - UNLOCK_FDPID_MUTEX; SvUPGRADE(sv,SVt_IV); SvIV_set(sv, pid); PL_forkprocess = pid; @@ -2437,8 +2548,9 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #if defined(atarist) || defined(EPOC) FILE *popen(); PerlIO * -Perl_my_popen((pTHX_ const char *cmd, const char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { + PERL_ARGS_ASSERT_MY_POPEN; PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. used 0 for 2nd parameter to PerlIO_importFILE; @@ -2450,7 +2562,7 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode) #if defined(DJGPP) FILE *djgpp_popen(); PerlIO * -Perl_my_popen((pTHX_ const char *cmd, const char *mode) +Perl_my_popen(pTHX_ const char *cmd, const char *mode) { PERL_FLUSHALL_FOR_CHILD; /* Call system's popen() to get a FILE *, then import it. @@ -2459,6 +2571,14 @@ Perl_my_popen((pTHX_ const char *cmd, const char *mode) */ return PerlIO_importFILE(djgpp_popen(cmd, mode), 0); } +#else +#if defined(__LIBCATAMOUNT__) +PerlIO * +Perl_my_popen(pTHX_ const char *cmd, const char *mode) +{ + return NULL; +} +#endif #endif #endif @@ -2516,11 +2636,13 @@ Perl_my_fork(void) #ifdef DUMP_FDS void -Perl_dump_fds(pTHX_ char *s) +Perl_dump_fds(pTHX_ const char *const s) { int fd; Stat_t tmpstatbuf; + PERL_ARGS_ASSERT_DUMP_FDS; + PerlIO_printf(Perl_debug_log,"%s", s); for (fd = 0; fd < 32; fd++) { if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0) @@ -2568,11 +2690,6 @@ dup2(int oldfd, int newfd) #ifndef PERL_MICRO #ifdef HAS_SIGACTION -#ifdef MACOS_TRADITIONAL -/* We don't want restart behavior on MacOS */ -#undef SA_RESTART -#endif - Sighandler_t Perl_rsignal(pTHX_ int signo, Sighandler_t handler) { @@ -2620,6 +2737,8 @@ Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save) dVAR; struct sigaction act; + PERL_ARGS_ASSERT_RSIGNAL_SAVE; + #ifdef USE_ITHREADS /* only "parent" interpreter can diddle signals */ if (PL_curinterp != aTHX) @@ -2721,7 +2840,7 @@ Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save) #endif /* !PERL_MICRO */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(__LIBCATAMOUNT__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -2732,14 +2851,9 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) Pid_t pid; Pid_t pid2; bool close_failed; - int saved_errno = 0; -#ifdef WIN32 - int saved_win32_errno; -#endif + dSAVEDERRNO; - LOCK_FDPID_MUTEX; svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE); - UNLOCK_FDPID_MUTEX; pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1; SvREFCNT_dec(*svp); *svp = &PL_sv_undef; @@ -2748,12 +2862,8 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) return my_syspclose(ptr); } #endif - if ((close_failed = (PerlIO_close(ptr) == EOF))) { - saved_errno = errno; -#ifdef WIN32 - saved_win32_errno = GetLastError(); -#endif - } + close_failed = (PerlIO_close(ptr) == EOF); + SAVE_ERRNO; #ifdef UTS if(PerlProc_kill(pid, 0) < 0) { return(pid); } /* HOM 12/23/91 */ #endif @@ -2771,19 +2881,28 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) rsignal_restore(SIGQUIT, &qstat); #endif if (close_failed) { - SETERRNO(saved_errno, 0); + RESTORE_ERRNO; return -1; } return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status)); } +#else +#if defined(__LIBCATAMOUNT__) +I32 +Perl_my_pclose(pTHX_ PerlIO *ptr) +{ + return -1; +} +#endif #endif /* !DOSISH */ -#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(MACOS_TRADITIONAL) +#if (!defined(DOSISH) || defined(OS2) || defined(WIN32) || defined(NETWARE)) && !defined(__LIBCATAMOUNT__) I32 Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) { dVAR; I32 result = 0; + PERL_ARGS_ASSERT_WAIT4PID; if (!pid) return -1; #ifdef PERL_USES_PL_PIDSTATUS @@ -2856,6 +2975,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) #endif if (result < 0 && errno == EINTR) { PERL_ASYNC_CHECK(); + errno = EINTR; /* reset in case a signal handler changed $! */ } return result; } @@ -2863,7 +2983,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) #ifdef PERL_USES_PL_PIDSTATUS void -Perl_pidgone(pTHX_ Pid_t pid, int status) +S_pidgone(pTHX_ Pid_t pid, int status) { register SV *sv; @@ -2907,24 +3027,36 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } #endif +#define PERL_REPEATCPY_LINEAR 4 void -Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count) -{ - register I32 todo; - register const char * const frombase = from; - PERL_UNUSED_CONTEXT; +Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count) +{ + PERL_ARGS_ASSERT_REPEATCPY; + + if (len == 1) + memset(to, *from, count); + else if (count) { + register char *p = to; + I32 items, linear, half; + + linear = count < PERL_REPEATCPY_LINEAR ? count : PERL_REPEATCPY_LINEAR; + for (items = 0; items < linear; ++items) { + register const char *q = from; + I32 todo; + for (todo = len; todo > 0; todo--) + *p++ = *q++; + } - if (len == 1) { - register const char c = *from; - while (count-- > 0) - *to++ = c; - return; - } - while (count-- > 0) { - for (todo = len; todo > 0; todo--) { - *to++ = *from++; + half = count / 2; + while (items <= half) { + I32 size = items * len; + memcpy(p, to, size); + p += size; + items *= 2; } - from = frombase; + + if (count > items) + memcpy(p, to, (count - items) * len); } } @@ -2938,6 +3070,8 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) Stat_t tmpstatbuf2; SV * const tmpsv = sv_newmortal(); + PERL_ARGS_ASSERT_SAME_DIRENT; + if (fa) fa++; else @@ -2949,13 +3083,13 @@ Perl_same_dirent(pTHX_ const char *a, const char *b) if (strNE(a,b)) return FALSE; if (fa == a) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, a, fa - a); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf1) < 0) return FALSE; if (fb == b) - sv_setpvn(tmpsv, ".", 1); + sv_setpvs(tmpsv, "."); else sv_setpvn(tmpsv, b, fb - b); if (PerlLIO_stat(SvPVX_const(tmpsv), &tmpstatbuf2) < 0) @@ -2976,6 +3110,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, register char *s; I32 len = 0; int retval; + char *bufend; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) # define SEARCH_EXTS ".bat", ".cmd", NULL # define MAX_EXT_LEN 4 @@ -2999,6 +3134,8 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, # define MAX_EXT_LEN 0 #endif + PERL_ARGS_ASSERT_FIND_SCRIPT; + /* * If dosearch is true and if scriptname does not contain path * delimiters, search the PATH for scriptname. @@ -3087,26 +3224,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, } #endif -#ifdef MACOS_TRADITIONAL - if (dosearch && !strchr(scriptname, ':') && - (s = PerlEnv_getenv("Commands"))) -#else if (dosearch && !strchr(scriptname, '/') #ifdef DOSISH && !strchr(scriptname, '\\') #endif && (s = PerlEnv_getenv("PATH"))) -#endif { bool seen_dot = 0; - PL_bufend = s + strlen(s); - while (s < PL_bufend) { -#ifdef MACOS_TRADITIONAL - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, - ',', - &len); -#else + bufend = s + strlen(s); + while (s < bufend) { #if defined(atarist) || defined(DOSISH) for (len = 0; *s # ifdef atarist @@ -3119,21 +3246,16 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, if (len < sizeof tmpbuf) tmpbuf[len] = '\0'; #else /* ! (atarist || DOSISH) */ - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, ':', &len); #endif /* ! (atarist || DOSISH) */ -#endif /* MACOS_TRADITIONAL */ - if (s < PL_bufend) + if (s < bufend) s++; if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ -#ifdef MACOS_TRADITIONAL - if (len && tmpbuf[len - 1] != ':') - tmpbuf[len++] = ':'; -#else if (len -# if defined(atarist) || defined(__MINT__) || defined(DOSISH) +# if defined(atarist) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' # endif @@ -3141,7 +3263,6 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, tmpbuf[len++] = '/'; if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; -#endif (void)my_strlcpy(tmpbuf + len, scriptname, sizeof(tmpbuf) - len); #endif /* !VMS */ @@ -3166,7 +3287,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, continue; if (S_ISREG(PL_statbuf.st_mode) && cando(S_IRUSR,TRUE,&PL_statbuf) -#if !defined(DOSISH) && !defined(MACOS_TRADITIONAL) +#if !defined(DOSISH) && cando(S_IXUSR,TRUE,&PL_statbuf) #endif ) @@ -3227,6 +3348,7 @@ void Perl_set_context(void *t) { dVAR; + PERL_ARGS_ASSERT_SET_CONTEXT; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); @@ -3291,6 +3413,7 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { char * const env_trans = PerlEnv_getenv(env_elem); PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_GETENV_LEN; if (env_trans) *len = strlen(env_trans); return env_trans; @@ -3588,11 +3711,13 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ #ifdef HAS_TM_TM_ZONE Time_t now; const struct tm* my_tm; + PERL_ARGS_ASSERT_INIT_TM; (void)time(&now); my_tm = localtime(&now); if (my_tm) Copy(my_tm, ptm, 1, struct tm); #else + PERL_ARGS_ASSERT_INIT_TM; PERL_UNUSED_ARG(ptm); #endif } @@ -3610,6 +3735,8 @@ Perl_mini_mktime(pTHX_ struct tm *ptm) int odd_cent, odd_year; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_MINI_MKTIME; + #define DAYS_PER_YEAR 365 #define DAYS_PER_QYEAR (4*DAYS_PER_YEAR+1) #define DAYS_PER_CENT (25*DAYS_PER_QYEAR-1) @@ -3804,6 +3931,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in struct tm mytm; int len; + PERL_ARGS_ASSERT_MY_STRFTIME; + init_tm(&mytm); /* XXX workaround - see init_tm() above */ mytm.tm_sec = sec; mytm.tm_min = min; @@ -3911,6 +4040,8 @@ Perl_getcwd_sv(pTHX_ register SV *sv) SvTAINTED_on(sv); #endif + PERL_ARGS_ASSERT_GETCWD_SV; + #ifdef HAS_GETCWD { char buf[MAXPATHLEN]; @@ -3948,6 +4079,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) for (;;) { DIR *dir; + int namelen; odev = cdev; oino = cino; @@ -3970,9 +4102,9 @@ Perl_getcwd_sv(pTHX_ register SV *sv) while ((dp = PerlDir_read(dir)) != NULL) { #ifdef DIRNAMLEN - const int namelen = dp->d_namlen; + namelen = dp->d_namlen; #else - const int namelen = strlen(dp->d_name); + namelen = strlen(dp->d_name); #endif /* skip . and .. */ if (SV_CWD_ISDOT(dp)) { @@ -4048,6 +4180,206 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #endif } +#define VERSION_MAX 0x7FFFFFFF + +const char * +Perl_prescan_version(pTHX_ const char *s, bool strict, + const char **errstr, + bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) { + bool qv = (sqv ? *sqv : FALSE); + int width = 3; + int saw_decimal = 0; + bool alpha = FALSE; + const char *d = s; + + PERL_ARGS_ASSERT_PRESCAN_VERSION; + + if (qv && isDIGIT(*d)) + goto dotted_decimal_version; + + if (*d == 'v') { /* explicit v-string */ + d++; + if (isDIGIT(*d)) { + qv = TRUE; + } + else { /* degenerate v-string */ + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + +dotted_decimal_version: + if (strict && d[0] == '0' && isDIGIT(d[1])) { + /* no leading zeros allowed */ + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } + + while (isDIGIT(*d)) /* integer part */ + d++; + + if (*d == '.') + { + saw_decimal++; + d++; /* decimal point */ + } + else + { + if (strict) { + /* require v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + else { + goto version_prescan_finish; + } + } + + { + int i = 0; + int j = 0; + while (isDIGIT(*d)) { /* just keep reading */ + i++; + while (isDIGIT(*d)) { + d++; j++; + /* maximum 3 digits between decimal */ + if (strict && j > 3) { + BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)"); + } + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + d++; + alpha = TRUE; + } + else if (*d == '.') { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + saw_decimal++; + d++; + } + else if (!isDIGIT(*d)) { + break; + } + j = 0; + } + + if (strict && i < 2) { + /* requires v1.2.3 */ + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + } + } /* end if dotted-decimal */ + else + { /* decimal versions */ + /* special strict case for leading '.' or '0' */ + if (strict) { + if (*d == '.') { + BADVERSION(s,errstr,"Invalid version format (0 before decimal required)"); + } + if (*d == '0' && isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (no leading zeros)"); + } + } + + /* consume all of the integer part */ + while (isDIGIT(*d)) + d++; + + /* look for a fractional part */ + if (*d == '.') { + /* we found it, so consume it */ + saw_decimal++; + d++; + } + else if (!*d || *d == ';' || isSPACE(*d) || *d == '}') { + if ( d == s ) { + /* found nothing */ + BADVERSION(s,errstr,"Invalid version format (version required)"); + } + /* found just an integer */ + goto version_prescan_finish; + } + else if ( d == s ) { + /* didn't find either integer or period */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + else if (*d == '_') { + /* underscore can't come after integer part */ + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + else if (isDIGIT(d[1])) { + BADVERSION(s,errstr,"Invalid version format (alpha without decimal)"); + } + else { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + } + else { + /* anything else after integer part is just invalid data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + /* scan the fractional part after the decimal point*/ + + if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '}') )) { + /* strict or lax-but-not-the-end */ + BADVERSION(s,errstr,"Invalid version format (fractional part required)"); + } + + while (isDIGIT(*d)) { + d++; + if (*d == '.' && isDIGIT(d[-1])) { + if (alpha) { + BADVERSION(s,errstr,"Invalid version format (underscores before decimal)"); + } + if (strict) { + BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); + } + d = (char *)s; /* start all over again */ + qv = TRUE; + goto dotted_decimal_version; + } + if (*d == '_') { + if (strict) { + BADVERSION(s,errstr,"Invalid version format (no underscores)"); + } + if ( alpha ) { + BADVERSION(s,errstr,"Invalid version format (multiple underscores)"); + } + if ( ! isDIGIT(d[1]) ) { + BADVERSION(s,errstr,"Invalid version format (misplaced underscore)"); + } + d++; + alpha = TRUE; + } + } + } + +version_prescan_finish: + while (isSPACE(*d)) + d++; + + if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '}') )) { + /* trailing non-numeric data */ + BADVERSION(s,errstr,"Invalid version format (non-numeric data)"); + } + + if (sqv) + *sqv = qv; + if (swidth) + *swidth = width; + if (ssaw_decimal) + *ssaw_decimal = saw_decimal; + if (salpha) + *salpha = alpha; + return d; +} + /* =for apidoc scan_version @@ -4058,12 +4390,12 @@ an RV. Function must be called with an already existing SV like sv = newSV(0); - s = scan_version(s,SV *sv, bool qv); + s = scan_version(s, SV *sv, bool qv); Performs some preprocessing to the string to ensure that it has the correct characteristics of a version. Flags the object if it contains an underscore (which denotes this -is a alpha version). The boolean qv denotes that the version +is an alpha version). The boolean qv denotes that the version should be interpreted as if it had multiple decimals, even if it doesn't. @@ -4076,11 +4408,16 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) const char *start; const char *pos; const char *last; - int saw_period = 0; - int alpha = 0; + const char *errstr = NULL; + int saw_decimal = 0; int width = 3; + bool alpha = FALSE; + bool vinf = FALSE; AV * const av = newAV(); SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ + + PERL_ARGS_ASSERT_SCAN_VERSION; + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ #ifndef NODEFAULT_SHAREKEYS @@ -4090,47 +4427,25 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) while (isSPACE(*s)) /* leading whitespace is OK */ s++; - if (*s == 'v') { - s++; /* get past 'v' */ - qv = 1; /* force quoted version processing */ - } - - start = last = pos = s; - - /* pre-scan the input string to check for decimals/underbars */ - while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) - { - if ( *pos == '.' ) - { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); - saw_period++ ; - last = pos; - } - else if ( *pos == '_' ) - { - if ( alpha ) - Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); - alpha = 1; - width = pos - last - 1; /* natural width of sub-version */ + last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha); + if (errstr) { + /* "undef" is a special case and not an error */ + if ( ! ( *s == 'u' && strEQ(s,"undef")) ) { + Perl_croak(aTHX_ "%s", errstr); } - pos++; } - if ( alpha && !saw_period ) - Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); - - if ( saw_period > 1 ) - qv = 1; /* force quoted version processing */ - + start = s; + if (*s == 'v') + s++; pos = s; if ( qv ) - hv_store((HV *)hv, "qv", 2, newSViv(qv), 0); + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv)); if ( alpha ) - hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0); + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha)); if ( !qv && width < 3 ) - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); while (isDIGIT(*pos)) pos++; @@ -4143,20 +4458,26 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* this is atoi() that delimits on underscores */ const char *end = pos; I32 mult = 1; - I32 orev; + I32 orev; /* the following if() will only be true after the decimal * point of a version originally created with a bare * floating point number, i.e. not quoted in any way */ - if ( !qv && s > start && saw_period == 1 ) { + if ( !qv && s > start && saw_decimal == 1 ) { mult *= 100; while ( s < end ) { - orev = rev; + orev = rev; rev += (*s - '0') * mult; mult /= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version %d",VERSION_MAX); + s = end - 1; + rev = VERSION_MAX; + vinf = 1; + } s++; if ( *s == '_' ) s++; @@ -4164,21 +4485,33 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } else { while (--end >= s) { - orev = rev; + orev = rev; rev += (*end - '0') * mult; mult *= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version"); + end = s - 1; + rev = VERSION_MAX; + vinf = 1; + } } } } /* Append revision */ av_push(av, newSViv(rev)); - if ( *pos == '.' ) + if ( vinf ) { + s = last; + break; + } + else if ( *pos == '.' ) s = ++pos; else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; + else if ( *pos == ',' && isDIGIT(pos[1]) ) + s = ++pos; else if ( isDIGIT(*pos) ) s = pos; else { @@ -4206,23 +4539,40 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) Compiler in question is: gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) for ( len = 2 - len; len > 0; len-- ) - av_push((AV *)sv, newSViv(0)); + av_push(MUTABLE_AV(sv), newSViv(0)); */ len = 2 - len; while (len-- > 0) av_push(av, newSViv(0)); } - if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ + /* need to save off the current version string for later */ + if ( vinf ) { + SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); + (void)hv_stores(MUTABLE_HV(hv), "original", orig); + (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1)); + } + else if ( s > start ) { + SV * orig = newSVpvn(start,s-start); + if ( qv && saw_decimal == 1 && *start != 'v' ) { + /* need to insert a v to be consistent */ + sv_insert(orig, 0, 0, "v", 1); + } + (void)hv_stores(MUTABLE_HV(hv), "original", orig); + } + else { + (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0")); av_push(av, newSViv(0)); + } + + /* And finally, store the AV in the hash */ + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); /* fix RT#19517 - special case 'undef' as string */ if ( *s == 'u' && strEQ(s,"undef") ) { s += 5; } - /* And finally, store the AV in the hash */ - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); return s; } @@ -4244,6 +4594,7 @@ Perl_new_version(pTHX_ SV *ver) { dVAR; SV * const rv = newSV(0); + PERL_ARGS_ASSERT_NEW_VERSION; if ( sv_derived_from(ver,"version") ) /* can just copy directly */ { I32 key; @@ -4260,19 +4611,25 @@ Perl_new_version(pTHX_ SV *ver) ver = SvRV(ver); /* Begin copying all of the elements */ - if ( hv_exists((HV *)ver, "qv", 2) ) - hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + if ( hv_exists(MUTABLE_HV(ver), "qv", 2) ) + (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1)); - if ( hv_exists((HV *)ver, "alpha", 5) ) - hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) ) + (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1)); - if ( hv_exists((HV*)ver, "width", 5 ) ) + if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) ) + { + const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE)); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); + } + + if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) ) { - const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE); + (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv)); } - sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); + sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE))); /* This will get reblessed later if a derived class*/ for ( key = 0; key <= av_len(sav); key++ ) { @@ -4280,7 +4637,7 @@ Perl_new_version(pTHX_ SV *ver) av_push(av, newSViv(rev)); } - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av))); return rv; } #ifdef SvVOK @@ -4290,6 +4647,9 @@ Perl_new_version(pTHX_ SV *ver) const STRLEN len = mg->mg_len; char * const version = savepvn( (const char*)mg->mg_ptr, len); sv_setpvn(rv,version,len); + /* this is for consistency with the pure Perl class */ + if ( isDIGIT(*version) ) + sv_insert(rv, 0, 0, "v", 1); Safefree(version); } else { @@ -4299,7 +4659,7 @@ Perl_new_version(pTHX_ SV *ver) } } #endif - return upg_version(rv); + return upg_version(rv, FALSE); } /* @@ -4307,24 +4667,27 @@ Perl_new_version(pTHX_ SV *ver) In-place upgrade of the supplied SV to a version object. - SV *sv = upg_version(SV *sv); + SV *sv = upg_version(SV *sv, bool qv); -Returns a pointer to the upgraded SV. +Returns a pointer to the upgraded SV. Set the boolean qv if you want +to force this SV to be interpreted as an "extended" version. =cut */ SV * -Perl_upg_version(pTHX_ SV *ver) +Perl_upg_version(pTHX_ SV *ver, bool qv) { const char *version, *s; - bool qv = 0; #ifdef SvVOK const MAGIC *mg; #endif - if ( SvNOK(ver) ) /* may get too much accuracy */ + PERL_ARGS_ASSERT_UPG_VERSION; + + if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) { + /* may get too much accuracy */ char tbuf[64]; #ifdef USE_LOCALE_NUMERIC char *loc = setlocale(LC_NUMERIC, "C"); @@ -4334,25 +4697,56 @@ Perl_upg_version(pTHX_ SV *ver) setlocale(LC_NUMERIC, loc); #endif while (tbuf[len-1] == '0' && len > 0) len--; + if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */ version = savepvn(tbuf, len); } #ifdef SvVOK else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - qv = 1; + qv = TRUE; } #endif else /* must be a string or something like a string */ { - version = savepv(SvPV_nolen(ver)); + STRLEN len; + version = savepv(SvPV(ver,len)); +#ifndef SvVOK +# if PERL_VERSION > 5 + /* This will only be executed for 5.6.0 - 5.8.0 inclusive */ + if ( len >= 3 && !instr(version,".") && !instr(version,"_") + && !(*version == 'u' && strEQ(version, "undef")) + && (*version < '0' || *version > '9') ) { + /* may be a v-string */ + SV * const nsv = sv_newmortal(); + const char *nver; + const char *pos; + int saw_decimal = 0; + sv_setpvf(nsv,"v%vd",ver); + pos = nver = savepv(SvPV_nolen(nsv)); + + /* scan the resulting formatted string */ + pos++; /* skip the leading 'v' */ + while ( *pos == '.' || isDIGIT(*pos) ) { + if ( *pos == '.' ) + saw_decimal++ ; + pos++; + } + + /* is definitely a v-string */ + if ( saw_decimal >= 2 ) { + Safefree(version); + version = nver; + } + } +# endif +#endif } s = scan_version(version, ver, qv); if ( *s != '\0' ) - if(ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_MISC), - "Version string '%s' contains invalid data; " - "ignoring: '%s'", version, s); + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Version string '%s' contains invalid data; " + "ignoring: '%s'", version, s); Safefree(version); return ver; } @@ -4384,13 +4778,16 @@ bool Perl_vverify(pTHX_ SV *vs) { SV *sv; + + PERL_ARGS_ASSERT_VVERIFY; + if ( SvROK(vs) ) vs = SvRV(vs); /* see if the appropriate elements exist */ if ( SvTYPE(vs) == SVt_PVHV - && hv_exists((HV*)vs, "version", 7) - && (sv = SvRV(*hv_fetchs((HV*)vs, "version", FALSE))) + && hv_exists(MUTABLE_HV(vs), "version", 7) + && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) && SvTYPE(sv) == SVt_PVAV ) return TRUE; else @@ -4417,8 +4814,11 @@ Perl_vnumify(pTHX_ SV *vs) I32 i, len, digit; int width; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; + + PERL_ARGS_ASSERT_VNUMIFY; + if ( SvROK(vs) ) vs = SvRV(vs); @@ -4426,29 +4826,27 @@ Perl_vnumify(pTHX_ SV *vs) Perl_croak(aTHX_ "Invalid version object"); /* see if various flags exist */ - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - if ( hv_exists((HV*)vs, "width", 5 ) ) - width = SvIV(*hv_fetchs((HV*)vs, "width", FALSE)); + if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) ) + width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE)); else width = 3; /* attempt to retrieve the version array */ - if ( !(av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)) ) ) { - sv_catpvs(sv,"0"); - return sv; + if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { + return newSVpvs("0"); } len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,"0"); - return sv; + return newSVpvs("0"); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "%d.", (int)PERL_ABS(digit)); + sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); @@ -4495,26 +4893,28 @@ Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; bool alpha = FALSE; - SV * const sv = newSV(0); + SV *sv; AV *av; + + PERL_ARGS_ASSERT_VNORMAL; + if ( SvROK(vs) ) vs = SvRV(vs); if ( !vverify(vs) ) Perl_croak(aTHX_ "Invalid version object"); - if ( hv_exists((HV*)vs, "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) ) alpha = TRUE; - av = (AV *)SvRV(*hv_fetchs((HV*)vs, "version", FALSE)); + av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))); len = av_len(av); if ( len == -1 ) { - sv_catpvs(sv,""); - return sv; + return newSVpvs(""); } digit = SvIV(*av_fetch(av, 0, 0)); - Perl_sv_setpvf(aTHX_ sv, "v%"IVdf, (IV)digit); + sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit); for ( i = 1 ; i < len ; i++ ) { digit = SvIV(*av_fetch(av, i, 0)); Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); @@ -4551,16 +4951,28 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { + PERL_ARGS_ASSERT_VSTRINGIFY; + if ( SvROK(vs) ) vs = SvRV(vs); - + if ( !vverify(vs) ) Perl_croak(aTHX_ "Invalid version object"); - if ( hv_exists((HV *)vs, "qv", 2) ) - return vnormal(vs); - else - return vnumify(vs); + if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) { + SV *pv; + pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE); + if ( SvPOK(pv) ) + return newSVsv(pv); + else + return &PL_sv_undef; + } + else { + if ( hv_exists(MUTABLE_HV(vs), "qv", 2) ) + return vnormal(vs); + else + return vnumify(vs); + } } /* @@ -4581,6 +4993,9 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) I32 left = 0; I32 right = 0; AV *lav, *rav; + + PERL_ARGS_ASSERT_VCMP; + if ( SvROK(lhv) ) lhv = SvRV(lhv); if ( SvROK(rhv) ) @@ -4593,13 +5008,13 @@ Perl_vcmp(pTHX_ SV *lhv, SV *rhv) Perl_croak(aTHX_ "Invalid version object"); /* get the left hand term */ - lav = (AV *)SvRV(*hv_fetchs((HV*)lhv, "version", FALSE)); - if ( hv_exists((HV*)lhv, "alpha", 5 ) ) + lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) ) lalpha = TRUE; /* and the right hand term */ - rav = (AV *)SvRV(*hv_fetchs((HV*)rhv, "version", FALSE)); - if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE))); + if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) ) ralpha = TRUE; l = av_len(lav); @@ -4789,12 +5204,12 @@ S_socketpair_udp (int fd[2]) { errno = ECONNABORTED; tidy_up_and_fail: { - const int save_errno = errno; + dSAVE_ERRNO; if (sockets[0] != -1) PerlLIO_close(sockets[0]); if (sockets[1] != -1) PerlLIO_close(sockets[1]); - errno = save_errno; + RESTORE_ERRNO; return -1; } } @@ -4893,14 +5308,14 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #endif tidy_up_and_fail: { - const int save_errno = errno; + dSAVE_ERRNO; if (listener != -1) PerlLIO_close(listener); if (connector != -1) PerlLIO_close(connector); if (acceptor != -1) PerlLIO_close(acceptor); - errno = save_errno; + RESTORE_ERRNO; return -1; } } @@ -4936,12 +5351,34 @@ Perl_sv_nosharing(pTHX_ SV *sv) PERL_UNUSED_ARG(sv); } +/* + +=for apidoc sv_destroyable + +Dummy routine which reports that object can be destroyed when there is no +sharing module present. It ignores its single SV argument, and returns +'true'. Exists to avoid test for a NULL function pointer and because it +could potentially warn under some level of strict-ness. + +=cut +*/ + +bool +Perl_sv_destroyable(pTHX_ SV *sv) +{ + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(sv); + return TRUE; +} + U32 Perl_parse_unicode_opts(pTHX_ const char **popt) { const char *p = *popt; U32 opt = 0; + PERL_ARGS_ASSERT_PARSE_UNICODE_OPTS; + if (*p) { if (isDIGIT(*p)) { opt = (U32) atoi(p); @@ -5101,7 +5538,7 @@ Perl_get_hash_seed(pTHX) * help. Sum in another random number that will * fill in the low bits. */ myseed += - (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); + (UV)(Drand01() * (NV)((((UV)1) << ((UVSIZE * 8 - RANDBITS))) - 1)); #endif /* RANDBITS < (UVSIZE * 8) */ if (myseed == 0) { /* Superparanoia. */ myseed = (UV)(Drand01() * (NV)UV_MAX); /* One more chance. */ @@ -5121,6 +5558,7 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) const char * const stashpv = CopSTASHPV(c); const char * const name = HvNAME_get(hv); PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_STASHPV_HVNAME_MATCH; if (stashpv == name) return TRUE; @@ -5134,13 +5572,14 @@ Perl_stashpv_hvname_match(pTHX_ const COP *c, const HV *hv) #ifdef PERL_GLOBAL_STRUCT +#define PERL_GLOBAL_STRUCT_INIT +#include "opcode.h" /* the ppaddr and check */ + struct perl_vars * Perl_init_global_struct(pTHX) { struct perl_vars *plvarsp = NULL; -#ifdef PERL_GLOBAL_STRUCT -# define PERL_GLOBAL_STRUCT_INIT -# include "opcode.h" /* the ppaddr and check */ +# ifdef PERL_GLOBAL_STRUCT const IV nppaddr = sizeof(Gppaddr)/sizeof(Perl_ppaddr_t); const IV ncheck = sizeof(Gcheck) /sizeof(Perl_check_t); # ifdef PERL_GLOBAL_STRUCT_PRIVATE @@ -5168,10 +5607,14 @@ Perl_init_global_struct(pTHX) # undef PERLVARIC # undef PERLVARISC # ifdef PERL_GLOBAL_STRUCT - plvarsp->Gppaddr = PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); + plvarsp->Gppaddr = + (Perl_ppaddr_t*) + PerlMem_malloc(nppaddr * sizeof(Perl_ppaddr_t)); if (!plvarsp->Gppaddr) exit(1); - plvarsp->Gcheck = PerlMem_malloc(ncheck * sizeof(Perl_check_t)); + plvarsp->Gcheck = + (Perl_check_t*) + PerlMem_malloc(ncheck * sizeof(Perl_check_t)); if (!plvarsp->Gcheck) exit(1); Copy(Gppaddr, plvarsp->Gppaddr, nppaddr, Perl_ppaddr_t); @@ -5180,8 +5623,8 @@ Perl_init_global_struct(pTHX) # ifdef PERL_SET_VARS PERL_SET_VARS(plvarsp); # endif -# undef PERL_GLOBAL_STRUCT_INIT -#endif +# undef PERL_GLOBAL_STRUCT_INIT +# endif return plvarsp; } @@ -5192,188 +5635,211 @@ Perl_init_global_struct(pTHX) void Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) { -#ifdef PERL_GLOBAL_STRUCT + PERL_ARGS_ASSERT_FREE_GLOBAL_STRUCT; +# ifdef PERL_GLOBAL_STRUCT # ifdef PERL_UNSET_VARS PERL_UNSET_VARS(plvarsp); # endif free(plvarsp->Gppaddr); free(plvarsp->Gcheck); -# ifdef PERL_GLOBAL_STRUCT_PRIVATE +# ifdef PERL_GLOBAL_STRUCT_PRIVATE free(plvarsp); -# endif -#endif +# endif +# endif } #endif /* PERL_GLOBAL_STRUCT */ #ifdef PERL_MEM_LOG -/* - * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled. +/* -DPERL_MEM_LOG: the Perl_mem_log_..() is compiled, including the + * the default implementation, unless -DPERL_MEM_LOG_NOIMPL is also + * given, and you supply your own implementation. + * + * The default implementation reads a single env var, PERL_MEM_LOG, + * expecting one or more of the following: * - * PERL_MEM_LOG_ENV: if defined, during run time the environment - * variable PERL_MEM_LOG will be consulted, and if the integer value - * of that is true, the logging will happen. (The default is to - * always log if the PERL_MEM_LOG define was in effect.) + * \d+ - fd fd to write to : must be 1st (atoi) + * 'm' - memlog was PERL_MEM_LOG=1 + * 's' - svlog was PERL_SV_LOG=1 + * 't' - timestamp was PERL_MEM_LOG_TIMESTAMP=1 + * + * This makes the logger controllable enough that it can reasonably be + * added to the system perl. */ -/* - * PERL_MEM_LOG_SPRINTF_BUF_SIZE: size of a (stack-allocated) buffer +/* -DPERL_MEM_LOG_SPRINTF_BUF_SIZE=X: size of a (stack-allocated) buffer * the Perl_mem_log_...() will use (either via sprintf or snprintf). */ #define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 -/* - * PERL_MEM_LOG_FD: the file descriptor the Perl_mem_log_...() will - * log to. You can also define in compile time PERL_MEM_LOG_ENV_FD, - * in which case the environment variable PERL_MEM_LOG_FD will be - * consulted for the file descriptor number to use. +/* -DPERL_MEM_LOG_FD=N: the file descriptor the Perl_mem_log_...() + * writes to. In the default logger, this is settable at runtime. */ #ifndef PERL_MEM_LOG_FD # define PERL_MEM_LOG_FD 2 /* If STDERR is too boring for you. */ #endif -Malloc_t -Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) -{ -#ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) +#ifndef PERL_MEM_LOG_NOIMPL + +# ifdef DEBUG_LEAKING_SCALARS +# define SV_LOG_SERIAL_FMT " [%lu]" +# define _SV_LOG_SERIAL_ARG(sv) , (unsigned long) (sv)->sv_debug_serial +# else +# define SV_LOG_SERIAL_FMT +# define _SV_LOG_SERIAL_ARG(sv) # endif + +static void +S_mem_log_common(enum mem_log_type mlt, const UV n, + const UV typesize, const char *type_name, const SV *sv, + Malloc_t oldalloc, Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) +{ + const char *pmlenv; + + PERL_ARGS_ASSERT_MEM_LOG_COMMON; + + pmlenv = PerlEnv_getenv("PERL_MEM_LOG"); + if (!pmlenv) + return; + if (mlt < MLT_NEW_SV ? strchr(pmlenv,'m') : strchr(pmlenv,'s')) { /* We can't use SVs or PerlIO for obvious reasons, * so we'll use stdio and low-level IO instead. */ char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; + # ifdef HAS_GETTIMEOFDAY +# define MEM_LOG_TIME_FMT "%10d.%06d: " +# define MEM_LOG_TIME_ARG (int)tv.tv_sec, (int)tv.tv_usec + struct timeval tv; gettimeofday(&tv, 0); +# else +# define MEM_LOG_TIME_FMT "%10d: " +# define MEM_LOG_TIME_ARG (int)when + Time_t when; + (void)time(&when); # endif /* If there are other OS specific ways of hires time than - * gettimeofday() (see ext/Time/HiRes), the easiest way is + * gettimeofday() (see ext/Time-HiRes), the easiest way is * probably that they would be used to fill in the struct * timeval. */ -# endif { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "alloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, n, typesize, - typename, n * typesize, PTR2UV(newalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -#endif + STRLEN len; + int fd = atoi(pmlenv); + if (!fd) + fd = PERL_MEM_LOG_FD; + + if (strchr(pmlenv, 't')) { + len = my_snprintf(buf, sizeof(buf), + MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); + PerlLIO_write(fd, buf, len); + } + switch (mlt) { + case MLT_ALLOC: + len = my_snprintf(buf, sizeof(buf), + "alloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(newalloc)); + break; + case MLT_REALLOC: + len = my_snprintf(buf, sizeof(buf), + "realloc: %s:%d:%s: %"IVdf" %"UVuf + " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", + filename, linenumber, funcname, n, typesize, + type_name, n * typesize, PTR2UV(oldalloc), + PTR2UV(newalloc)); + break; + case MLT_FREE: + len = my_snprintf(buf, sizeof(buf), + "free: %s:%d:%s: %"UVxf"\n", + filename, linenumber, funcname, + PTR2UV(oldalloc)); + break; + case MLT_NEW_SV: + case MLT_DEL_SV: + len = my_snprintf(buf, sizeof(buf), + "%s_SV: %s:%d:%s: %"UVxf SV_LOG_SERIAL_FMT "\n", + mlt == MLT_NEW_SV ? "new" : "del", + filename, linenumber, funcname, + PTR2UV(sv) _SV_LOG_SERIAL_ARG(sv)); + break; + default: + len = 0; + } + PerlLIO_write(fd, buf, len); } } +} +#endif /* !PERL_MEM_LOG_NOIMPL */ + +#ifndef PERL_MEM_LOG_NOIMPL +# define \ + mem_log_common_if(alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) \ + mem_log_common (alty, num, tysz, tynm, sv, oal, nal, flnm, ln, fnnm) +#else +/* this is suboptimal, but bug compatible. User is providing their + own implemenation, but is getting these functions anyway, and they + do nothing. But _NOIMPL users should be able to cope or fix */ +# define \ + mem_log_common_if(alty, num, tysz, tynm, u, oal, nal, flnm, ln, fnnm) \ + /* mem_log_common_if_PERL_MEM_LOG_NOIMPL */ #endif + +Malloc_t +Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, + Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_ALLOC, n, typesize, type_name, + NULL, NULL, newalloc, + filename, linenumber, funcname); return newalloc; } Malloc_t -Perl_mem_log_realloc(const UV n, const UV typesize, const char *typename, Malloc_t oldalloc, Malloc_t newalloc, const char *filename, const int linenumber, const char *funcname) -{ -#ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) -# endif - { - /* We can't use SVs or PerlIO for obvious reasons, - * so we'll use stdio and low-level IO instead. */ - char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; - gettimeofday(&tv, 0); -# endif - { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "realloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf" -> %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, n, typesize, - typename, n * typesize, PTR2UV(oldalloc), - PTR2UV(newalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -# endif - } - } -#endif +Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, + Malloc_t oldalloc, Malloc_t newalloc, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_REALLOC, n, typesize, type_name, + NULL, oldalloc, newalloc, + filename, linenumber, funcname); return newalloc; } Malloc_t -Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) +Perl_mem_log_free(Malloc_t oldalloc, + const char *filename, const int linenumber, + const char *funcname) { -#ifdef PERL_MEM_LOG_STDERR -# if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; -# endif -# ifdef PERL_MEM_LOG_ENV - s = PerlEnv_getenv("PERL_MEM_LOG"); - if (s ? atoi(s) : 0) -# endif - { - /* We can't use SVs or PerlIO for obvious reasons, - * so we'll use stdio and low-level IO instead. */ - char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; -# ifdef PERL_MEM_LOG_TIMESTAMP - struct timeval tv; - gettimeofday(&tv, 0); -# endif - { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " -# endif - "free: %s:%d:%s: %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, -# endif - filename, linenumber, funcname, - PTR2UV(oldalloc)); -# ifdef PERL_MEM_LOG_ENV_FD - s = PerlEnv_getenv("PERL_MEM_LOG_FD"); - PerlLIO_write(s ? atoi(s) : PERL_MEM_LOG_FD, buf, len); -# else - PerlLIO_write(PERL_MEM_LOG_FD, buf, len); -# endif - } - } -#endif + mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, + filename, linenumber, funcname); return oldalloc; } +void +Perl_mem_log_new_sv(const SV *sv, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, + filename, linenumber, funcname); +} + +void +Perl_mem_log_del_sv(const SV *sv, + const char *filename, const int linenumber, + const char *funcname) +{ + mem_log_common_if(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, + filename, linenumber, funcname); +} + #endif /* PERL_MEM_LOG */ /* @@ -5390,6 +5856,7 @@ int Perl_my_sprintf(char *buffer, const char* pat, ...) { va_list args; + PERL_ARGS_ASSERT_MY_SPRINTF; va_start(args, pat); vsprintf(buffer, pat, args); va_end(args); @@ -5415,6 +5882,7 @@ Perl_my_snprintf(char *buffer, const Size_t len, const char *format, ...) dTHX; int retval; va_list ap; + PERL_ARGS_ASSERT_MY_SNPRINTF; va_start(ap, format); #ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, ap); @@ -5446,6 +5914,9 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap int retval; #ifdef NEED_VA_COPY va_list apc; + + PERL_ARGS_ASSERT_MY_VSNPRINTF; + Perl_va_copy(ap, apc); # ifdef HAS_VSNPRINTF retval = vsnprintf(buffer, len, format, apc); @@ -5504,7 +5975,8 @@ Perl_my_clearenv(pTHX) bsiz = l + 1; /* + 1 for the \0. */ buf = (char*)safesysmalloc(bufsiz); } - my_strlcpy(buf, *environ, l + 1); + memcpy(buf, *environ, l); + buf[l] = '\0'; (void)unsetenv(buf); } (void)safesysfree(buf); @@ -5534,11 +6006,16 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size) { dVAR; void *p; + PERL_ARGS_ASSERT_MY_CXT_INIT; if (*index == -1) { /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) MUTEX_LOCK(&PL_my_ctx_mutex); +#endif *index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif } /* make sure the array is big enough */ @@ -5568,6 +6045,8 @@ Perl_my_cxt_index(pTHX_ const char *my_cxt_key) dVAR; int index; + PERL_ARGS_ASSERT_MY_CXT_INDEX; + for (index = 0; index < PL_my_cxt_index; index++) { const char *key = PL_my_cxt_keys[index]; /* try direct pointer compare first - there are chances to success, @@ -5586,12 +6065,18 @@ Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) void *p; int index; + PERL_ARGS_ASSERT_MY_CXT_INIT; + index = Perl_my_cxt_index(aTHX_ my_cxt_key); if (index == -1) { /* this module hasn't been allocated an index yet */ +#if defined(USE_ITHREADS) MUTEX_LOCK(&PL_my_ctx_mutex); +#endif index = PL_my_cxt_index++; +#if defined(USE_ITHREADS) MUTEX_UNLOCK(&PL_my_ctx_mutex); +#endif } /* make sure the array is big enough */ @@ -5672,6 +6157,8 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) * it's for informational purposes only. */ + PERL_ARGS_ASSERT_GET_DB_SUB; + save_item(dbsv); if (!PERLDB_SUB_NN) { GV * const gv = CvGV(cv); @@ -5679,10 +6166,11 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || strEQ(GvNAME(gv), "END") || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ - !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) { + !( (SvTYPE(*svp) == SVt_PVGV) + && (GvCV((const GV *)*svp) == cv) )))) { /* Use GV from the stack as a fallback. */ /* GV is potentially non-unique, or contain different CV. */ - SV * const tmp = newRV((SV*)cv); + SV * const tmp = newRV(MUTABLE_SV(cv)); sv_setsv(dbsv, tmp); SvREFCNT_dec(tmp); } @@ -5699,6 +6187,38 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) } } +int +Perl_my_dirfd(pTHX_ DIR * dir) { + + /* Most dirfd implementations have problems when passed NULL. */ + if(!dir) + return -1; +#ifdef HAS_DIRFD + return dirfd(dir); +#elif defined(HAS_DIR_DD_FD) + return dir->dd_fd; +#else + Perl_die(aTHX_ PL_no_func, "dirfd"); + /* NOT REACHED */ + return 0; +#endif +} + +REGEXP * +Perl_get_re_arg(pTHX_ SV *sv) { + + if (sv) { + if (SvMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv)) + sv = MUTABLE_SV(SvRV(sv)); + if (SvTYPE(sv) == SVt_REGEXP) + return (REGEXP*) sv; + } + + return NULL; +} + /* * Local variables: * c-indentation-style: bsd