X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/99fff99d79aa793bf9a6e0ce2bb18ced085ad1e2..cfe24c19270f6ccb34742b7199b21718cd2fd8aa:/util.c diff --git a/util.c b/util.c index 4c9516b..02c84c8 100644 --- a/util.c +++ b/util.c @@ -140,7 +140,7 @@ Perl_safesysmalloc(MEM_SIZE size) #endif #ifdef DEBUGGING if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); + Perl_croak_nocontext("panic: malloc, size=%" UVuf, (UV) size); #endif if (!size) size = 1; /* malloc(0) is NASTY on our system */ #ifdef PERL_DEBUG_READONLY_COW @@ -180,7 +180,7 @@ Perl_safesysmalloc(MEM_SIZE size) header->size = size; #endif ptr = (Malloc_t)((char*)ptr+PERL_MEMORY_DEBUG_HEADER_SIZE); - DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size)); } else { @@ -257,7 +257,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) #endif #ifdef DEBUGGING if ((SSize_t)size < 0) - Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); + Perl_croak_nocontext("panic: realloc, size=%" UVuf, (UV)size); #endif #ifdef PERL_DEBUG_READONLY_COW if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE, @@ -304,8 +304,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) /* 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)); + 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) { #ifdef USE_MDH @@ -333,7 +333,7 @@ Perl_safesysfree(Malloc_t where) #ifdef ALWAYS_NEED_THX dTHX; #endif - DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); + DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%" UVxf ": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { #ifdef USE_MDH Malloc_t where_intrn = (Malloc_t)((char*)where-PERL_MEMORY_DEBUG_HEADER_SIZE); @@ -419,7 +419,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) #endif #ifdef DEBUGGING if ((SSize_t)size < 0 || (SSize_t)count < 0) - Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf, + Perl_croak_nocontext("panic: calloc, size=%" UVuf ", count=%" UVuf, (UV)size, (UV)count); #endif #ifdef PERL_DEBUG_READONLY_COW @@ -442,7 +442,7 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) ptr = (Malloc_t)PerlMem_calloc(count ? count : 1, size ? size : 1); #endif 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)total_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) { #ifdef USE_MDH { @@ -522,17 +522,26 @@ Free_t Perl_mfree (Malloc_t where) #endif -/* copy a string up to some (non-backslashed) delimiter, if any */ +/* copy a string up to some (non-backslashed) delimiter, if any. + * With allow_escape, converts \ to , while leaves + * \ as-is. + * Returns the position in the src string of the closing delimiter, if + * any, or returns fromend otherwise. + * This is the internal implementation for Perl_delimcpy and + * Perl_delimcpy_no_escape. + */ -char * -Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen) +static char * +S_delimcpy_intern(char *to, const char *toend, const char *from, + const char *fromend, int delim, I32 *retlen, + const bool allow_escape) { I32 tolen; PERL_ARGS_ASSERT_DELIMCPY; for (tolen = 0; from < fromend; from++, tolen++) { - if (*from == '\\') { + if (allow_escape && *from == '\\' && from + 1 < fromend) { if (from[1] != delim) { if (to < toend) *to++ = *from; @@ -551,25 +560,61 @@ Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend return (char *)from; } -/* return ptr to little string in big string, NULL if not found */ -/* This routine was donated by Corey Satten. */ - char * -Perl_instr(const char *big, const char *little) +Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen) { + PERL_ARGS_ASSERT_DELIMCPY; - PERL_ARGS_ASSERT_INSTR; + return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 1); +} + +char * +Perl_delimcpy_no_escape(char *to, const char *toend, const char *from, + const char *fromend, int delim, I32 *retlen) +{ + PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE; - return strstr((char*)big, (char*)little); + return S_delimcpy_intern(to, toend, from, fromend, delim, retlen, 0); } -/* same as instr but allow embedded nulls. The end pointers point to 1 beyond - * the final character desired to be checked */ +/* +=head1 Miscellaneous Functions + +=for apidoc Am|char *|ninstr|char * big|char * bigend|char * little|char * little_end + +Find the first (leftmost) occurrence of a sequence of bytes within another +sequence. This is the Perl version of C, extended to handle +arbitrary sequences, potentially containing embedded C characters (C +is what the initial C in the function name stands for; some systems have an +equivalent, C, but with a somewhat different API). + +Another way of thinking about this function is finding a needle in a haystack. +C points to the first byte in the haystack. C points to one byte +beyond the final byte in the haystack. C points to the first byte in +the needle. C points to one byte beyond the final byte in the +needle. All the parameters must be non-C. + +The function returns C if there is no occurrence of C within +C. If C is the empty string, C is returned. + +Because this function operates at the byte level, and because of the inherent +characteristics of UTF-8 (or UTF-EBCDIC), it will work properly if both the +needle and the haystack are strings with the same UTF-8ness, but not if the +UTF-8ness differs. + +=cut + +*/ char * Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) { PERL_ARGS_ASSERT_NINSTR; + +#ifdef HAS_MEMMEM + return ninstr(big, bigend, little, lend); +#else + if (little >= lend) return (char*)big; { @@ -588,9 +633,23 @@ Perl_ninstr(const char *big, const char *bigend, const char *little, const char } } return NULL; + +#endif + } -/* reverse of the above--find last substring */ +/* +=head1 Miscellaneous Functions + +=for apidoc Am|char *|rninstr|char * big|char * bigend|char * little|char * little_end + +Like C>, but instead finds the final (rightmost) occurrence of a +sequence of bytes within another sequence, returning C if there is no +such occurrence. + +=cut + +*/ char * Perl_rninstr(const char *big, const char *bigend, const char *little, const char *lend) @@ -672,21 +731,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) SvUPGRADE(sv, SVt_PVMG); SvIOK_off(sv); SvNOK_off(sv); - SvVALID_on(sv); - /* "deep magic", the comment used to add. The use of MAGIC itself isn't - really. MAGIC was originally added in 79072805bf63abe5 (perl 5.0 alpha 2) - to call SvVALID_off() if the scalar was assigned to. - - The comment itself (and "deeper magic" below) date back to - 378cc40b38293ffc (perl 2.0). "deep magic" was an annotation on - str->str_pok |= 2; - where the magic (presumably) was that the scalar had a BM table hidden - inside itself. - - As MAGIC is always present on BMs [in Perl 5 :-)], we can use it to store - the table instead of the previous (somewhat hacky) approach of co-opting - the string buffer and storing it after the string. */ + /* add PERL_MAGIC_bm magic holding the FBM lookup table */ assert(!mg_find(sv, PERL_MAGIC_bm)); mg = sv_magicext(sv, NULL, PERL_MAGIC_bm, &PL_vtbl_bm, NULL, 0); @@ -721,9 +767,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) } } BmUSEFUL(sv) = 100; /* Initial value */ - if (flags & FBMcf_TAIL) - SvTAIL_on(sv); - DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %"UVuf"\n", + ((XPVNV*)SvANY(sv))->xnv_u.xnv_bm_tail = cBOOL(flags & FBMcf_TAIL); + DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %" UVuf "\n", s[rarest], (UV)rarest)); } @@ -766,11 +811,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U const unsigned char *little = (const unsigned char *)SvPV_const(littlestr,l); STRLEN littlelen = l; const I32 multiline = flags & FBMrf_MULTILINE; + bool valid = SvVALID(littlestr); + bool tail = valid ? cBOOL(SvTAIL(littlestr)) : FALSE; PERL_ARGS_ASSERT_FBM_INSTR; if ((STRLEN)(bigend - big) < littlelen) { - if ( SvTAIL(littlestr) + if ( tail && ((STRLEN)(bigend - big) == littlelen - 1) && (littlelen == 1 || (*big == *little && @@ -784,19 +831,19 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U return (char*)big; /* Cannot be SvTAIL! */ case 1: - if (SvTAIL(littlestr) && !multiline) /* Anchor only! */ + if (tail && !multiline) /* Anchor only! */ /* [-1] is safe because we know that bigend != big. */ return (char *) (bigend - (bigend[-1] == '\n')); s = (unsigned char *)memchr((void*)big, *little, bigend-big); if (s) return (char *)s; - if (SvTAIL(littlestr)) + if (tail) return (char *) bigend; return NULL; case 2: - if (SvTAIL(littlestr) && !multiline) { + if (tail && !multiline) { /* a littlestr with SvTAIL must be of the form "X\n" (where X * is a single char). It is anchored, and can only match * "....X\n" or "....X" */ @@ -874,7 +921,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U /* failed to find 2 chars; try anchored match at end without * the \n */ - if (SvTAIL(littlestr) && bigend[0] == little[0]) + if (tail && bigend[0] == little[0]) return (char *)bigend; return NULL; } @@ -883,7 +930,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U break; /* Only lengths 0 1 and 2 have special-case code. */ } - if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */ + if (tail && !multiline) { /* tail anchored? */ s = bigend - littlelen; if (s >= big && bigend[-1] == '\n' && *s == *little /* Automatically of length > 2 */ @@ -899,12 +946,12 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U return NULL; } - if (!SvVALID(littlestr)) { + if (!valid) { /* not compiled; use Perl_ninstr() instead */ char * const b = ninstr((char*)big,(char*)bigend, (char*)little, (char*)little + littlelen); - if (!b && SvTAIL(littlestr)) { /* Automatically multiline! */ + if (!b && tail) { /* Automatically multiline! */ /* Chop \n from littlestr: */ s = bigend - littlelen + 1; if (*s == *little @@ -976,7 +1023,7 @@ Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U } check_end: if ( s == bigend - && SvTAIL(littlestr) + && tail && memEQ((char *)(bigend - littlelen), (char *)(oldlittle - littlelen), littlelen) ) return (char*)bigend - littlelen; @@ -1477,7 +1524,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) cop = PL_curcop; if (CopLINE(cop)) - Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, + Perl_sv_catpvf(aTHX_ sv, " at %s line %" IVdf, OutCopFILE(cop), (IV)CopLINE(cop)); /* Seems that GvIO() can be untrustworthy during global destruction. */ if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) @@ -1486,7 +1533,7 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) STRLEN l; const bool line_mode = (RsSIMPLE(PL_rs) && *SvPV_const(PL_rs,l) == '\n' && l == 1); - Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf, + Perl_sv_catpvf(aTHX_ sv, ", <%" SVf "> %s %" IVdf, SVfARG(PL_last_in_gv == PL_argvgv ? &PL_sv_no : sv_2mortal(newSVhek(GvNAME_HEK(PL_last_in_gv)))), @@ -2265,10 +2312,13 @@ Perl_unlnk(pTHX_ const char *f) /* unlink all versions of a file */ /* this is a drop-in replacement for bcopy(), except for the return * value, which we need to be able to emulate memcpy() */ -#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) +#if !defined(HAS_MEMCPY) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY)) void * Perl_my_bcopy(const void *vfrom, void *vto, size_t len) { +#if defined(HAS_BCOPY) && defined(HAS_SAFE_BCOPY) + bcopy(vfrom, vto, len); +#else const unsigned char *from = (const unsigned char *)vfrom; unsigned char *to = (unsigned char *)vto; @@ -2284,6 +2334,8 @@ Perl_my_bcopy(const void *vfrom, void *vto, size_t len) while (len--) *(--to) = *(--from); } +#endif + return vto; } #endif @@ -3133,10 +3185,7 @@ S_pidgone(pTHX_ Pid_t pid, int status) } #endif -#if defined(OS2) || defined(__amigaos4__) -# if defined(__amigaos4__) && defined(pclose) -# undef pclose -# endif +#if defined(OS2) int pclose(); #ifdef HAS_FORK int /* Cannot prototype with I32 @@ -3653,7 +3702,7 @@ Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) if (name && HEK_LEN(name)) Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %"HEKf" opened only for %sput", + "Filehandle %" HEKf " opened only for %sput", HEKfARG(name), direction); else Perl_warner(aTHX_ packWARN(WARN_IO), @@ -3696,13 +3745,13 @@ Perl_report_evil_fh(pTHX_ const GV *gv) ? "socket" : "filehandle"); const bool have_name = name && SvCUR(name); Perl_warner(aTHX_ packWARN(warn_type), - "%s%s on %s %s%s%"SVf, func, pars, vile, type, + "%s%s on %s %s%s%" SVf, func, pars, vile, type, have_name ? " " : "", SVfARG(have_name ? name : &PL_sv_no)); if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) Perl_warner( aTHX_ packWARN(warn_type), - "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n", + "\t(Are you trying to call %s%s on dirhandle%s%" SVf "?)\n", func, pars, have_name ? " " : "", SVfARG(have_name ? name : &PL_sv_no) ); @@ -4034,8 +4083,8 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in #define SV_CWD_RETURN_UNDEF \ -sv_setsv(sv, &PL_sv_undef); \ -return FALSE + sv_set_undef(sv); \ + return FALSE #define SV_CWD_ISDOT(dp) \ (dp->d_name[0] == '.' && (dp->d_name[1] == '\0' || \ @@ -4079,8 +4128,7 @@ Perl_getcwd_sv(pTHX_ SV *sv) return TRUE; } else { - sv_setsv(sv, &PL_sv_undef); - return FALSE; + SV_CWD_RETURN_UNDEF; } } @@ -4576,7 +4624,7 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) the_end_of_the_opts_parser: if (opt & ~PERL_UNICODE_ALL_FLAGS) - Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf, + Perl_croak(aTHX_ "Unknown Unicode option value %" UVuf, (UV) (opt & ~PERL_UNICODE_ALL_FLAGS)); *popt = p; @@ -4924,29 +4972,29 @@ S_mem_log_common(enum mem_log_type mlt, const UV n, switch (mlt) { case MLT_ALLOC: len = my_snprintf(buf, sizeof(buf), - "alloc: %s:%d:%s: %"IVdf" %"UVuf - " %s = %"IVdf": %"UVxf"\n", + "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", + "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", + "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", + "%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)); @@ -4979,6 +5027,8 @@ Perl_mem_log_alloc(const UV n, const UV typesize, const char *type_name, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_ALLOC; + mem_log_common_if(MLT_ALLOC, n, typesize, type_name, NULL, NULL, newalloc, filename, linenumber, funcname); @@ -4991,6 +5041,8 @@ Perl_mem_log_realloc(const UV n, const UV typesize, const char *type_name, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_REALLOC; + mem_log_common_if(MLT_REALLOC, n, typesize, type_name, NULL, oldalloc, newalloc, filename, linenumber, funcname); @@ -5002,6 +5054,8 @@ Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) { + PERL_ARGS_ASSERT_MEM_LOG_FREE; + mem_log_common_if(MLT_FREE, 0, 0, "", NULL, oldalloc, NULL, filename, linenumber, funcname); return oldalloc; @@ -5255,7 +5309,8 @@ Perl_my_vsnprintf(char *buffer, const Size_t len, const char *format, va_list ap PERL_UNUSED_ARG(buffer); PERL_UNUSED_ARG(len); PERL_UNUSED_ARG(format); - PERL_UNUSED_ARG(ap); + /* the cast is to avoid gcc -Wsizeof-array-argument complaining */ + PERL_UNUSED_ARG((void*)ap); Perl_croak_nocontext("panic: my_vsnprintf not available with quadmath"); return 0; #else @@ -5581,7 +5636,7 @@ Perl_xs_handshake(const U32 key, void * v_my_perl, const char * file, ...) if(apiverlen != sizeof("v" PERL_API_VERSION_STRING)-1 || memNE(api_p, "v" PERL_API_VERSION_STRING, sizeof("v" PERL_API_VERSION_STRING)-1)) - Perl_croak_nocontext("Perl API version %s of %"SVf" does not match %s", + Perl_croak_nocontext("Perl API version %s of %" SVf " does not match %s", api_p, SVfARG(PL_stack_base[ax + 0]), "v" PERL_API_VERSION_STRING); } @@ -5613,10 +5668,10 @@ S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, else { /* XXX GV_ADDWARN */ vn = "XS_VERSION"; - sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0); + sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); if (!sv || !SvOK(sv)) { vn = "VERSION"; - sv = get_sv(Perl_form(aTHX_ "%"SVf"::%s", SVfARG(module), vn), 0); + sv = get_sv(Perl_form(aTHX_ "%" SVf "::%s", SVfARG(module), vn), 0); } } if (sv) { @@ -5626,17 +5681,17 @@ S_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, xssv = upg_version(xssv, 0); if ( vcmp(pmsv,xssv) ) { SV *string = vstringify(xssv); - SV *xpt = Perl_newSVpvf(aTHX_ "%"SVf" object version %"SVf + SV *xpt = Perl_newSVpvf(aTHX_ "%" SVf " object version %" SVf " does not match ", SVfARG(module), SVfARG(string)); SvREFCNT_dec(string); string = vstringify(pmsv); if (vn) { - Perl_sv_catpvf(aTHX_ xpt, "$%"SVf"::%s %"SVf, SVfARG(module), vn, + Perl_sv_catpvf(aTHX_ xpt, "$%" SVf "::%s %" SVf, SVfARG(module), vn, SVfARG(string)); } else { - Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %"SVf, SVfARG(string)); + Perl_sv_catpvf(aTHX_ xpt, "bootstrap parameter %" SVf, SVfARG(string)); } SvREFCNT_dec(string); @@ -5662,9 +5717,13 @@ Note that C is the full size of the destination buffer and the result is guaranteed to be C-terminated if there is room. Note that room for the C should be included in C. +The return value is the total length that C would have if C is +sufficiently large. Thus it is the initial length of C plus the length of +C. If C is smaller than the return, the excess was not appended. + =cut -Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat +Description stolen from http://man.openbsd.org/strlcat.3 */ #ifndef HAS_STRLCAT Size_t @@ -5693,9 +5752,12 @@ This operates on C C-terminated strings. C copies up to S> characters from the string C to C, C-terminating the result if C is not 0. +The return value is the total length C would be if the copy completely +succeeded. If it is larger than C, the excess was not copied. + =cut -Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy +Description stolen from http://man.openbsd.org/strlcpy.3 */ #ifndef HAS_STRLCPY Size_t @@ -6146,7 +6208,7 @@ static const char* atos_parse(const char* p, *source_name_size = source_name_end - p; if (grok_atoUV(source_number_start, &uv, &source_line_end) && source_line_end == close_paren - && uv <= MAX_STRLEN + && uv <= PERL_INT_MAX ) { *source_line = (STRLEN)uv; return p; @@ -6213,14 +6275,14 @@ static void atos_symbolize(atos_context* ctx, char out[1024]; UV cnt = fread(out, 1, sizeof(out), fp); if (cnt < sizeof(out)) { - const char* p = atos_parse(out + cnt, out, + const char* p = atos_parse(out + cnt - 1, out, source_name_size, source_line); if (p) { Newx(*source_name, - *source_name_size + 1, char); + *source_name_size, char); Copy(p, *source_name, - *source_name_size + 1, char); + *source_name_size, char); } } pclose(fp); @@ -6345,14 +6407,15 @@ Perl_get_c_backtrace(pTHX_ int depth, int skip) for (i = skip; i < try_depth; i++) { Dl_info* dl_info = &dl_infos[i]; - total_bytes += sizeof(Perl_c_backtrace_frame); - + object_name_sizes[i] = 0; source_names[i] = NULL; source_name_sizes[i] = 0; source_lines[i] = 0; /* Yes, zero from dladdr() is failure. */ if (dladdr(raw_frames[i], dl_info)) { + total_bytes += sizeof(Perl_c_backtrace_frame); + object_name_sizes[i] = dl_info->dli_fname ? strlen(dl_info->dli_fname) : 0; symbol_name_sizes[i] = @@ -6540,7 +6603,7 @@ Perl_get_c_backtrace_dump(pTHX_ int depth, int skip) if (frame->source_name_size && frame->source_name_offset && frame->source_line_number) { - Perl_sv_catpvf(aTHX_ dsv, "\t%s:%"UVuf, + Perl_sv_catpvf(aTHX_ dsv, "\t%s:%" UVuf, (char*)bt + frame->source_name_offset, (UV)frame->source_line_number); } else { @@ -6613,6 +6676,84 @@ int perl_tsa_mutex_destroy(perl_mutex* mutex) #endif + +#ifdef USE_DTRACE + +/* log a sub call or return */ + +void +Perl_dtrace_probe_call(pTHX_ CV *cv, bool is_call) +{ + const char *func; + const char *file; + const char *stash; + const COP *start; + line_t line; + + PERL_ARGS_ASSERT_DTRACE_PROBE_CALL; + + if (CvNAMED(cv)) { + HEK *hek = CvNAME_HEK(cv); + func = HEK_KEY(hek); + } + else { + GV *gv = CvGV(cv); + func = GvENAME(gv); + } + start = (const COP *)CvSTART(cv); + file = CopFILE(start); + line = CopLINE(start); + stash = CopSTASHPV(start); + + if (is_call) { + PERL_SUB_ENTRY(func, file, line, stash); + } + else { + PERL_SUB_RETURN(func, file, line, stash); + } +} + + +/* log a require file loading/loaded */ + +void +Perl_dtrace_probe_load(pTHX_ const char *name, bool is_loading) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_LOAD; + + if (is_loading) { + PERL_LOADING_FILE(name); + } + else { + PERL_LOADED_FILE(name); + } +} + + +/* log an op execution */ + +void +Perl_dtrace_probe_op(pTHX_ const OP *op) +{ + PERL_ARGS_ASSERT_DTRACE_PROBE_OP; + + PERL_OP_ENTRY(OP_NAME(op)); +} + + +/* log a compile/run phase change */ + +void +Perl_dtrace_probe_phase(pTHX_ enum perl_phase phase) +{ + const char *ph_old = PL_phase_names[PL_phase]; + const char *ph_new = PL_phase_names[phase]; + + PERL_PHASE_CHANGE(ph_new, ph_old); +} + +#endif + /* * ex: set ts=8 sts=4 sw=4 et: */