X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/713cef20be507239588df9cdc5f99ce04b7e0b40..daba3364ed9f39ba44b28575c032f6db52d47881:/util.c diff --git a/util.c b/util.c index c5f69ae..3b31ffc 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, 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. @@ -178,11 +178,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 +198,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 +268,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(PL_memory_wrap); +#ifdef PERL_TRACK_MEMPOOL + if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size) + total_size += sTHX; + else + Perl_croak_nocontext(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 +292,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 +321,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); } @@ -342,6 +372,8 @@ Perl_delimcpy(pTHX_ register char *to, register const char *toend, register cons register I32 tolen; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_DELIMCPY; + for (tolen = 0; from < fromend; from++, tolen++) { if (*from == '\\') { if (from[1] != delim) { @@ -371,6 +403,8 @@ Perl_instr(pTHX_ register const char *big, register const char *little) register I32 first; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_INSTR; + if (!little) return (char*)big; first = *little++; @@ -401,22 +435,23 @@ Perl_instr(pTHX_ register const char *big, register const char *little) char * Perl_ninstr(pTHX_ const char *big, const char *bigend, const char *little, const char *lend) { + PERL_ARGS_ASSERT_NINSTR; PERL_UNUSED_CONTEXT; 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; @@ -432,6 +467,8 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit register const char * const littleend = lend; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_RNINSTR; + if (little >= littleend) return (char*)bigend; bigbeg = big; @@ -478,9 +515,11 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) register const U8 *s; register U32 i; STRLEN len; - I32 rarest = 0; + 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() */ @@ -492,6 +531,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) return; SvUPGRADE(sv, SVt_PVGV); SvIOK_off(sv); + SvNOK_off(sv); + SvVALID_on(sv); if (len > 2) { const unsigned char *sb; const U8 mlen = (len>255) ? 255 : (U8)len; @@ -502,7 +543,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); - table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] = (U8)flags; i = 0; sb = s - mlen + 1; /* first char (maybe) */ while (s >= sb) { @@ -514,7 +554,6 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET); } sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */ - SvVALID_on(sv); s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */ for (i = 0; i < len; i++) { @@ -523,13 +562,14 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) frequency = PL_freq[s[i]]; } } + BmFLAGS(sv) = (U8)flags; BmRARE(sv) = s[rarest]; - BmPREVIOUS_set(sv, rarest); + BmPREVIOUS(sv) = rarest; BmUSEFUL(sv) = 100; /* Initial value */ if (flags & FBMcf_TAIL) SvTAIL_on(sv); - DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n", - BmRARE(sv),BmPREVIOUS(sv))); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n", + BmRARE(sv),(unsigned long)BmPREVIOUS(sv))); } /* If SvTAIL(littlestr), it has a fake '\n' at end. */ @@ -557,6 +597,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) @@ -724,7 +766,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } check_end: if ( s == bigend - && (table[PERL_FBM_FLAGS_OFFSET_FROM_TABLE] & FBMcf_TAIL) + && (BmFLAGS(littlestr) & FBMcf_TAIL) && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; @@ -760,6 +802,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)); @@ -768,7 +812,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++; @@ -843,6 +887,8 @@ Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len) register const U8 *b = (const U8 *)s2; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_IBCMP; + while (len--) { if (*a != *b && *a != PL_fold[*b]) return 1; @@ -859,6 +905,8 @@ Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len) 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]) return 1; @@ -952,6 +1000,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 @@ -967,6 +1038,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); @@ -983,7 +1056,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; @@ -1006,6 +1079,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); @@ -1038,6 +1112,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); @@ -1048,6 +1123,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); } @@ -1059,6 +1135,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); @@ -1071,6 +1148,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); @@ -1083,6 +1161,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; @@ -1116,6 +1196,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') { /* @@ -1132,7 +1214,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, @@ -1154,9 +1239,11 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) 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; @@ -1170,8 +1257,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)); + mPUSHp(message, msglen); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1225,8 +1312,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 = newSVpvn_flags(message, msglen, utf8); SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1238,7 +1324,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; @@ -1268,9 +1354,6 @@ S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, message = NULL; } - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die/croak: message = %s\ndiehook = %p\n", - thr, message, PL_diehook)); if (PL_diehook) { S_vdie_common(aTHX_ message, *msglen, *utf8, FALSE); } @@ -1286,17 +1369,10 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) STRLEN msglen; I32 utf8 = 0; - DEBUG_S(PerlIO_printf(Perl_debug_log, - "%p: die: curstack = %p, mainstack = %p\n", - thr, PL_curstack, PL_mainstack)); - message = vdie_croak_common(pat, args, &msglen, &utf8); 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", - thr, PL_restartop, was_in_eval, PL_top_env)); if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) JMPENV_JUMP(3); return PL_restartop; @@ -1309,6 +1385,7 @@ Perl_die_nocontext(const char* pat, ...) dTHX; OP *o; va_list args; + PERL_ARGS_ASSERT_DIE_NOCONTEXT; va_start(args, pat); o = vdie(pat, &args); va_end(args); @@ -1401,6 +1478,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *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)) return; @@ -1415,6 +1494,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); @@ -1434,6 +1514,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); @@ -1445,6 +1526,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); @@ -1455,6 +1537,7 @@ 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); @@ -1464,6 +1547,7 @@ 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; @@ -1545,6 +1629,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) ? @@ -1692,6 +1777,8 @@ Perl_setenv_getix(pTHX_ const char *nam) { register I32 i; register const I32 len = strlen(nam); + + PERL_ARGS_ASSERT_SETENV_GETIX; PERL_UNUSED_CONTEXT; for (i = 0; environ[i]; i++) { @@ -1716,6 +1803,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; @@ -1729,6 +1818,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++; @@ -1750,6 +1841,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; @@ -1763,6 +1856,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; @@ -1778,6 +1873,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; @@ -1787,24 +1884,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 @@ -1837,7 +1961,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; @@ -2131,6 +2258,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; @@ -2139,9 +2268,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(MACOS_TRADITIONAL) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) dVAR; int p[2]; register I32 This, that; @@ -2150,6 +2279,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; @@ -2267,13 +2398,17 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) PerlLIO_close(pp[0]); return PerlIO_fdopen(p[This], mode); #else +# ifdef OS2 /* Same, without fork()ing and all extra overhead... */ + return my_syspopen4(aTHX_ NULL, mode, n, args); +# else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; +# endif #endif } /* 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(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { @@ -2286,6 +2421,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) { @@ -2432,8 +2569,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; @@ -2445,7 +2583,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. @@ -2454,6 +2592,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 @@ -2511,11 +2657,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) @@ -2615,6 +2763,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) @@ -2716,7 +2866,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(MACOS_TRADITIONAL) && !defined(__LIBCATAMOUNT__) I32 Perl_my_pclose(pTHX_ PerlIO *ptr) { @@ -2771,14 +2921,23 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) } 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(MACOS_TRADITIONAL) && !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 @@ -2851,6 +3010,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; } @@ -2909,6 +3069,8 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi register const char * const frombase = from; PERL_UNUSED_CONTEXT; + PERL_ARGS_ASSERT_REPEATCPY; + if (len == 1) { register const char c = *from; while (count-- > 0) @@ -2933,6 +3095,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 @@ -2944,13 +3108,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) @@ -2971,6 +3135,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 @@ -2994,6 +3159,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. @@ -3095,10 +3262,10 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, { bool seen_dot = 0; - PL_bufend = s + strlen(s); - while (s < PL_bufend) { + bufend = s + strlen(s); + while (s < bufend) { #ifdef MACOS_TRADITIONAL - s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend, + s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, bufend, ',', &len); #else @@ -3114,12 +3281,12 @@ 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 */ @@ -3222,6 +3389,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); @@ -3286,6 +3454,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; @@ -3583,11 +3752,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 } @@ -3605,6 +3776,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) @@ -3799,6 +3972,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; @@ -3906,6 +4081,8 @@ Perl_getcwd_sv(pTHX_ register SV *sv) SvTAINTED_on(sv); #endif + PERL_ARGS_ASSERT_GETCWD_SV; + #ifdef HAS_GETCWD { char buf[MAXPATHLEN]; @@ -4043,6 +4220,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #endif } +#define VERSION_MAX 0x7FFFFFFF /* =for apidoc scan_version @@ -4053,12 +4231,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. @@ -4074,23 +4252,25 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) int saw_period = 0; int alpha = 0; int width = 3; + bool vinf = FALSE; AV * const av = newAV(); SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ - (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ -#ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif + PERL_ARGS_ASSERT_SCAN_VERSION; + + (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ while (isSPACE(*s)) /* leading whitespace is OK */ s++; + start = last = s; + if (*s == 'v') { s++; /* get past 'v' */ qv = 1; /* force quoted version processing */ } - start = last = pos = s; + pos = s; /* pre-scan the input string to check for decimals/underbars */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) @@ -4115,17 +4295,21 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( alpha && !saw_period ) Perl_croak(aTHX_ "Invalid version format (alpha without decimal)"); + if ( alpha && saw_period && width == 0 ) + Perl_croak(aTHX_ "Invalid version format (misplaced _ in number)"); + if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ + last = pos; 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++; @@ -4138,7 +4322,7 @@ 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 @@ -4147,11 +4331,18 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( !qv && s > start && saw_period == 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 )) { + if(ckWARN(WARN_OVERFLOW)) + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version %d",VERSION_MAX); + s = end - 1; + rev = VERSION_MAX; + vinf = 1; + } s++; if ( *s == '_' ) s++; @@ -4159,18 +4350,29 @@ 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 )) { + if(ckWARN(WARN_OVERFLOW)) + Perl_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; @@ -4201,23 +4403,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_period == 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; } @@ -4239,6 +4458,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; @@ -4247,27 +4467,30 @@ Perl_new_version(pTHX_ SV *ver) /* This will get reblessed later if a derived class*/ SV * const hv = newSVrv(rv, "version"); (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ -#ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif if ( SvROK(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((HV*)ver, "width", FALSE)); - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE)); + (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width)); } - sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); + if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) ) + { + SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE); + (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv)); + } + + 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++ ) { @@ -4275,7 +4498,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 @@ -4285,6 +4508,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 ( *version != 'v' ) + sv_insert(rv, 0, 0, "v", 1); Safefree(version); } else { @@ -4294,7 +4520,7 @@ Perl_new_version(pTHX_ SV *ver) } } #endif - return upg_version(rv); + return upg_version(rv, FALSE); } /* @@ -4302,24 +4528,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"); @@ -4329,6 +4558,7 @@ 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 @@ -4339,7 +4569,36 @@ Perl_upg_version(pTHX_ SV *ver) #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,"_") ) { + /* may be a v-string */ + SV * const nsv = sv_newmortal(); + const char *nver; + const char *pos; + int saw_period = 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_period++ ; + pos++; + } + + /* is definitely a v-string */ + if ( saw_period == 2 ) { + Safefree(version); + version = nver; + } + } +# endif +#endif } s = scan_version(version, ver, qv); @@ -4379,13 +4638,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 @@ -4414,6 +4676,9 @@ Perl_vnumify(pTHX_ SV *vs) bool alpha = FALSE; SV * const sv = newSV(0); AV *av; + + PERL_ARGS_ASSERT_VNUMIFY; + if ( SvROK(vs) ) vs = SvRV(vs); @@ -4421,16 +4686,16 @@ 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)) ) ) { + if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) { sv_catpvs(sv,"0"); return sv; } @@ -4492,15 +4757,18 @@ Perl_vnormal(pTHX_ SV *vs) bool alpha = FALSE; SV * const sv = newSV(0); 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 ) @@ -4546,16 +4814,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); + } } /* @@ -4576,6 +4856,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) ) @@ -4588,13 +4871,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); @@ -4931,12 +5214,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); @@ -5116,6 +5421,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; @@ -5129,13 +5435,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 @@ -5163,10 +5470,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); @@ -5175,8 +5486,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; } @@ -5187,16 +5498,17 @@ 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 */ @@ -5207,9 +5519,15 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) * PERL_MEM_LOG: the Perl_mem_log_..() will be compiled. * * 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.) + * variables PERL_MEM_LOG and PERL_SV_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.) + * + * PERL_MEM_LOG_TIMESTAMP: if defined, a timestamp will be logged + * before every memory logging entry. This can be turned off at run + * time by setting the environment variable PERL_MEM_LOG_TIMESTAMP + * to zero. */ /* @@ -5228,15 +5546,27 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) # 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 + +# 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) +{ # if defined(PERL_MEM_LOG_ENV) || defined(PERL_MEM_LOG_ENV_FD) - char *s; + const char *s; # endif + + PERL_ARGS_ASSERT_MEM_LOG_COMMON; + # ifdef PERL_MEM_LOG_ENV - s = getenv("PERL_MEM_LOG"); + s = PerlEnv_getenv(mlt < MLT_NEW_SV ? "PERL_MEM_LOG" : "PERL_SV_LOG"); if (s ? atoi(s) : 0) # endif { @@ -5244,9 +5574,16 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t * 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 @@ -5254,73 +5591,73 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *typename, Malloc_t * timeval. */ # endif { - const STRLEN len = - my_snprintf(buf, - sizeof(buf), -# ifdef PERL_MEM_LOG_TIMESTAMP - "%10d.%06d: " + int fd = PERL_MEM_LOG_FD; + STRLEN len; + +# ifdef PERL_MEM_LOG_ENV_FD + if ((s = PerlEnv_getenv("PERL_MEM_LOG_FD"))) { + fd = atoi(s); + } # endif - "alloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf"\n", -# ifdef PERL_MEM_LOG_TIMESTAMP - (int)tv.tv_sec, (int)tv.tv_usec, +# ifdef PERL_MEM_LOG_TIMESTAMP + s = PerlEnv_getenv("PERL_MEM_LOG_TIMESTAMP"); + if (!s || atoi(s)) { + len = my_snprintf(buf, sizeof(buf), + MEM_LOG_TIME_FMT, MEM_LOG_TIME_ARG); + PerlLIO_write(fd, buf, len); + } # 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 + 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; + } + PerlLIO_write(fd, buf, len); } } +} +#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) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname); #endif 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) +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) { #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 - } - } + mem_log_common(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname); #endif return newalloc; } @@ -5329,46 +5666,27 @@ Malloc_t 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 - } - } + mem_log_common(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname); #endif return oldalloc; } +void +Perl_mem_log_new_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_NEW_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname); +#endif +} + +void +Perl_mem_log_del_sv(const SV *sv, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + mem_log_common(MLT_DEL_SV, 0, 0, "", sv, NULL, NULL, filename, linenumber, funcname); +#endif +} + #endif /* PERL_MEM_LOG */ /* @@ -5385,6 +5703,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); @@ -5410,6 +5729,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); @@ -5441,6 +5761,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); @@ -5499,7 +5822,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); @@ -5516,18 +5840,20 @@ Perl_my_clearenv(pTHX) #ifdef PERL_IMPLICIT_CONTEXT -/* implements the MY_CXT_INIT macro. The first time a module is loaded, +/* Implements the MY_CXT_INIT macro. The first time a module is loaded, the global PL_my_cxt_index is incremented, and that value is assigned to that module's static my_cxt_index (who's address is passed as an arg). Then, for each interpreter this function is called for, it makes sure a void* slot is available to hang the static data off, by allocating or extending the interpreter's PL_my_cxt_list array */ +#ifndef PERL_GLOBAL_STRUCT_PRIVATE void * 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 */ MUTEX_LOCK(&PL_my_ctx_mutex); @@ -5553,7 +5879,74 @@ Perl_my_cxt_init(pTHX_ int *index, size_t size) Zero(p, size, char); return p; } -#endif + +#else /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ + +int +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, + * and it's much faster. + */ + if ((key == my_cxt_key) || strEQ(key, my_cxt_key)) + return index; + } + return -1; +} + +void * +Perl_my_cxt_init(pTHX_ const char *my_cxt_key, size_t size) +{ + dVAR; + 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 */ + MUTEX_LOCK(&PL_my_ctx_mutex); + index = PL_my_cxt_index++; + MUTEX_UNLOCK(&PL_my_ctx_mutex); + } + + /* make sure the array is big enough */ + if (PL_my_cxt_size <= index) { + int old_size = PL_my_cxt_size; + int i; + if (PL_my_cxt_size) { + while (PL_my_cxt_size <= index) + PL_my_cxt_size *= 2; + Renew(PL_my_cxt_list, PL_my_cxt_size, void *); + Renew(PL_my_cxt_keys, PL_my_cxt_size, const char *); + } + else { + PL_my_cxt_size = 16; + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + Newx(PL_my_cxt_keys, PL_my_cxt_size, const char *); + } + for (i = old_size; i < PL_my_cxt_size; i++) { + PL_my_cxt_keys[i] = 0; + PL_my_cxt_list[i] = 0; + } + } + PL_my_cxt_keys[index] = my_cxt_key; + /* newSV() allocates one more than needed */ + p = (void*)SvPVX(newSV(size-1)); + PL_my_cxt_list[index] = p; + Zero(p, size, char); + return p; +} +#endif /* #ifndef PERL_GLOBAL_STRUCT_PRIVATE */ +#endif /* PERL_IMPLICIT_CONTEXT */ #ifndef HAS_STRLCAT Size_t @@ -5588,6 +5981,12 @@ Perl_my_strlcpy(char *dst, const char *src, Size_t size) } #endif +#if defined(_MSC_VER) && (_MSC_VER >= 1300) && (_MSC_VER < 1400) && (WINVER < 0x0500) +/* VC7 or 7.1, building with pre-VC7 runtime libraries. */ +long _ftol( double ); /* Defined by VC6 C libs. */ +long _ftol2( double dblSource ) { return _ftol( dblSource ); } +#endif + void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { @@ -5597,6 +5996,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); @@ -5607,7 +6008,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((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); } @@ -5624,6 +6025,41 @@ 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) { + SV *tmpsv; + + if (sv) { + if (SvMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv) && + (tmpsv = MUTABLE_SV(SvRV(sv))) && /* assign deliberate */ + SvTYPE(tmpsv) == SVt_REGEXP) + { + return (REGEXP*) tmpsv; + } + } + + return NULL; +} + /* * Local variables: * c-indentation-style: bsd