X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2bda37bab5fb768caff2b228fda376b75df4815c..937b2e03e541820ee46da2b99aa38321dddcc776:/util.c diff --git a/util.c b/util.c index 8c836c2..5e69cb9 100644 --- a/util.c +++ b/util.c @@ -12,7 +12,7 @@ * '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"] + * [p.598 of _The Lord of the Rings_, III/xi: "The Palantír"] */ /* This file contains assorted utility routines. @@ -41,10 +41,6 @@ int putenv(char *); #endif -#ifdef I_SYS_WAIT -# include -#endif - #ifdef HAS_SELECT # ifdef I_SYS_SELECT # include @@ -98,8 +94,8 @@ Perl_safesysmalloc(MEM_SIZE size) size += sTHX; #endif #ifdef DEBUGGING - if ((long)size < 0) - Perl_croak_nocontext("panic: malloc"); + if ((SSize_t)size < 0) + Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size); #endif ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */ PERL_ALLOC_CHECK(ptr); @@ -176,7 +172,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) = (struct perl_memory_debug_header *)where; if (header->interpreter != aTHX) { - Perl_croak_nocontext("panic: realloc from wrong pool"); + Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p", + header->interpreter, aTHX); } assert(header->next->prev == header); assert(header->prev->next == header); @@ -191,8 +188,8 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) } #endif #ifdef DEBUGGING - if ((long)size < 0) - Perl_croak_nocontext("panic: realloc"); + if ((SSize_t)size < 0) + Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size); #endif ptr = (Malloc_t)PerlMem_realloc(where,size); PERL_ALLOC_CHECK(ptr); @@ -262,14 +259,19 @@ Perl_safesysfree(Malloc_t where) = (struct perl_memory_debug_header *)where; if (header->interpreter != aTHX) { - Perl_croak_nocontext("panic: free from wrong pool"); + Perl_croak_nocontext("panic: free from wrong pool, %p!=%p", + header->interpreter, aTHX); } if (!header->prev) { Perl_croak_nocontext("panic: duplicate free"); } - if (!(header->next) || header->next->prev != header - || header->prev->next != header) { - Perl_croak_nocontext("panic: bad free"); + if (!(header->next)) + Perl_croak_nocontext("panic: bad free, header->next==NULL"); + if (header->next->prev != header || header->prev->next != header) { + Perl_croak_nocontext("panic: bad free, ->next->prev=%p, " + "header=%p, ->prev->next=%p", + header->next->prev, header, + header->prev->next); } /* Unlink us from the chain. */ header->next->prev = header->prev; @@ -320,8 +322,9 @@ Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size) } #endif /* HAS_64K_LIMIT */ #ifdef DEBUGGING - if ((long)size < 0 || (long)count < 0) - Perl_croak_nocontext("panic: calloc"); + if ((SSize_t)size < 0 || (SSize_t)count < 0) + Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf, + (UV)size, (UV)count); #endif #ifdef PERL_TRACK_MEMPOOL /* Have to use malloc() because we've added some space for our tracking @@ -464,7 +467,8 @@ Perl_instr(register const char *big, register const char *little) return NULL; } -/* same as instr but allow embedded nulls */ +/* same as instr but allow embedded nulls. The end pointers point to 1 beyond + * the final character desired to be checked */ char * Perl_ninstr(const char *big, const char *bigend, const char *little, const char *lend) @@ -553,11 +557,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) PERL_ARGS_ASSERT_FBM_COMPILE; - /* Refuse to fbm_compile a studied scalar, as this gives more flexibility in - SV flag usage. No real-world code would ever end up using a studied - scalar as a compile-time second argument to index, so this isn't a real - pessimisation. */ - if (SvSCREAM(sv)) + if (isGV_with_GP(sv)) return; if (SvVALID(sv)) @@ -572,7 +572,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) s = (U8*)SvPV_force_mutable(sv, len); if (len == 0) /* TAIL might be on a zero-length string. */ return; - SvUPGRADE(sv, SVt_PVGV); + SvUPGRADE(sv, SVt_PVMG); SvIOK_off(sv); SvNOK_off(sv); SvVALID_on(sv); @@ -639,8 +639,8 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) /* =for apidoc fbm_instr -Returns the location of the SV in the string delimited by C and -C. It returns C if the string can't be found. The C +Returns the location of the SV in the string delimited by C and +C. It returns C if the string can't be found. The C does not have to be fbm_compiled, but the search will not be as fast then. @@ -834,109 +834,21 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit } } -/* start_shift, end_shift are positive quantities which give offsets - of ends of some substring of bigstr. - If "last" we want the last occurrence. - old_posp is the way of communication between consequent calls if - the next call needs to find the . - The initial *old_posp should be -1. - - Note that we take into account SvTAIL, so one can get extra - optimizations if _ALL flag is set. - */ - -/* If SvTAIL is actually due to \Z or \z, this gives false positives - if PL_multiline. In fact if !PL_multiline the authoritative answer - is not supported yet. */ - char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { dVAR; - register const unsigned char *big; - register I32 pos; - register I32 previous; - register I32 first; - register const unsigned char *little; - register I32 stop_pos; - register const unsigned char *littleend; - I32 found = 0; - PERL_ARGS_ASSERT_SCREAMINSTR; - - assert(SvTYPE(littlestr) == SVt_PVGV); - assert(SvVALID(littlestr)); - - if (*old_posp == -1 - ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0 - : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) { - cant_find: - if ( BmRARE(littlestr) == '\n' - && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { - little = (const unsigned char *)(SvPVX_const(littlestr)); - littleend = little + SvCUR(littlestr); - first = *little++; - goto check_tail; - } - return NULL; - } - - little = (const unsigned char *)(SvPVX_const(littlestr)); - littleend = little + SvCUR(littlestr); - first = *little++; - /* The value of pos we can start at: */ - previous = BmPREVIOUS(littlestr); - big = (const unsigned char *)(SvPVX_const(bigstr)); - /* The value of pos we can stop at: */ - stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous); - if (previous + start_shift > stop_pos) { -/* - stop_pos does not include SvTAIL in the count, so this check is incorrect - (I think) - see [ID 20010618.006] and t/op/study.t. HVDS 2001/06/19 -*/ -#if 0 - if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */ - goto check_tail; -#endif - return NULL; - } - while (pos < previous + start_shift) { - if (!(pos += PL_screamnext[pos])) - goto cant_find; - } - big -= previous; - do { - register const unsigned char *s, *x; - if (pos >= stop_pos) break; - if (big[pos] != first) - continue; - for (x=big+pos+1,s=little; s < littleend; /**/ ) { - if (*s++ != *x++) { - s--; - break; - } - } - if (s == littleend) { - *old_posp = pos; - if (!last) return (char *)(big+pos); - found = 1; - } - } while ( pos += PL_screamnext[pos] ); - if (last && found) - return (char *)(big+(*old_posp)); - check_tail: - if (!SvTAIL(littlestr) || (end_shift > 0)) - return NULL; - /* Ignore the trailing "\n". This code is not microoptimized */ - big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); - stop_pos = littleend - little; /* Actual littlestr len */ - if (stop_pos == 0) - return (char*)big; - big -= stop_pos; - if (*big == first - && ((stop_pos == 1) || - memEQ((char *)(big + 1), (char *)little, stop_pos - 1))) - return (char*)big; + PERL_UNUSED_ARG(bigstr); + PERL_UNUSED_ARG(littlestr); + PERL_UNUSED_ARG(start_shift); + PERL_UNUSED_ARG(end_shift); + PERL_UNUSED_ARG(old_posp); + PERL_UNUSED_ARG(last); + + /* This function must only ever be called on a scalar with study magic, + but those do not happen any more. */ + Perl_croak(aTHX_ "panic: screaminstr"); return NULL; } @@ -1113,7 +1025,7 @@ Perl_savesharedpvn(pTHX_ const char *const pv, const STRLEN len) { char *const newaddr = (char*)PerlMemShared_malloc(len + 1); - PERL_ARGS_ASSERT_SAVESHAREDPVN; + /* PERL_ARGS_ASSERT_SAVESHAREDPVN; */ if (!newaddr) { return write_no_mem(); @@ -1394,10 +1306,13 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) && IoLINES(GvIOp(PL_last_in_gv))) { + STRLEN l; const bool line_mode = (RsSIMPLE(PL_rs) && - SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); - Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf, - PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv), + *SvPV_const(PL_rs,l) == '\n' && l == 1); + 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)))), line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } @@ -1543,7 +1458,7 @@ Perl_die_sv(pTHX_ SV *baseex) { PERL_ARGS_ASSERT_DIE_SV; croak_sv(baseex); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ return NULL; } @@ -1565,7 +1480,7 @@ Perl_die_nocontext(const char* pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); return NULL; } @@ -1577,7 +1492,7 @@ Perl_die(pTHX_ const char* pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); return NULL; } @@ -1677,7 +1592,7 @@ Perl_croak_nocontext(const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); } #endif /* PERL_IMPLICIT_CONTEXT */ @@ -1688,7 +1603,7 @@ Perl_croak(pTHX_ const char *pat, ...) va_list args; va_start(args, pat); vcroak(pat, &args); - /* NOTREACHED */ + assert(0); /* NOTREACHED */ va_end(args); } @@ -1931,7 +1846,8 @@ S_ckwarn_common(pTHX_ U32 w) STRLEN * Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, STRLEN size) { - const MEM_SIZE len_wanted = sizeof(STRLEN) + size; + const MEM_SIZE len_wanted = + sizeof(STRLEN) + (size > WARNsize ? size : WARNsize); PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_NEW_WARNINGS_BITFIELD; @@ -1941,6 +1857,8 @@ Perl_new_warnings_bitfield(pTHX_ STRLEN *buffer, const char *const bits, PerlMemShared_realloc(buffer, len_wanted)); buffer[0] = size; Copy(bits, (buffer + 1), size, char); + if (size < WARNsize) + Zero((char *)(buffer + 1) + size, WARNsize - size, char); return buffer; } @@ -2672,7 +2590,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) int pid2, status; PerlLIO_close(p[This]); if (n != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read"); + Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); do { pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); @@ -2786,9 +2704,6 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) default, binary, low-level mode; see PerlIOBuf_open(). */ PerlLIO_setmode((*mode == 'r'), O_BINARY); #endif -#ifdef THREADS_HAVE_PIDS - PL_ppid = (IV)getppid(); -#endif PL_forkprocess = 0; #ifdef PERL_USES_PL_PIDSTATUS hv_clear(PL_pidstatus); /* we have no children */ @@ -2831,7 +2746,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) int pid2, status; PerlLIO_close(p[This]); if (n != sizeof(int)) - Perl_croak(aTHX_ "panic: kid popen errno read"); + Perl_croak(aTHX_ "panic: kid popen errno read, n=%u", n); do { pid2 = wait4pid(pid, &status, 0); } while (pid2 == -1 && errno == EINTR); @@ -3341,7 +3256,7 @@ Perl_my_pclose(pTHX_ PerlIO *ptr) #define PERL_REPEATCPY_LINEAR 4 void -Perl_repeatcpy(register char *to, register const char *from, I32 len, register I32 count) +Perl_repeatcpy(register char *to, register const char *from, I32 len, register IV count) { PERL_ARGS_ASSERT_REPEATCPY; @@ -3349,19 +3264,19 @@ Perl_repeatcpy(register char *to, register const char *from, I32 len, register I memset(to, *from, count); else if (count) { register char *p = to; - I32 items, linear, half; + IV 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; + IV todo; for (todo = len; todo > 0; todo--) *p++ = *q++; } half = count / 2; while (items <= half) { - I32 size = items * len; + IV size = items * len; memcpy(p, to, size); p += size; items *= 2; @@ -3618,6 +3533,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, seen_dot = 1; /* Disable message. */ if (!xfound) { if (flags & 1) { /* do or die? */ + /* diag_listed_as: Can't execute %s */ Perl_croak(aTHX_ "Can't %s %s%s%s", (xfailed ? "execute" : "find"), (xfailed ? xfailed : scriptname), @@ -3641,8 +3557,9 @@ Perl_get_context(void) #if defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; - if (pthread_getspecific(PL_thr_key, &t)) - Perl_croak_nocontext("panic: pthread_getspecific"); + int error = pthread_getspecific(PL_thr_key, &t) + if (error) + Perl_croak_nocontext("panic: pthread_getspecific, error=%d", error); return (void*)t; # else # ifdef I_MACH_CTHREADS @@ -3665,8 +3582,11 @@ Perl_set_context(void *t) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else - if (pthread_setspecific(PL_thr_key, t)) - Perl_croak_nocontext("panic: pthread_setspecific"); + { + const int error = pthread_setspecific(PL_thr_key, t); + if (error) + Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error); + } # endif #else PERL_UNUSED_ARG(t); @@ -3736,104 +3656,10 @@ Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) MGVTBL* Perl_get_vtbl(pTHX_ int vtbl_id) { - const MGVTBL* result; PERL_UNUSED_CONTEXT; - switch(vtbl_id) { - case want_vtbl_sv: - result = &PL_vtbl_sv; - break; - case want_vtbl_env: - result = &PL_vtbl_env; - break; - case want_vtbl_envelem: - result = &PL_vtbl_envelem; - break; - case want_vtbl_sig: - result = &PL_vtbl_sig; - break; - case want_vtbl_sigelem: - result = &PL_vtbl_sigelem; - break; - case want_vtbl_pack: - result = &PL_vtbl_pack; - break; - case want_vtbl_packelem: - result = &PL_vtbl_packelem; - break; - case want_vtbl_dbline: - result = &PL_vtbl_dbline; - break; - case want_vtbl_isa: - result = &PL_vtbl_isa; - break; - case want_vtbl_isaelem: - result = &PL_vtbl_isaelem; - break; - case want_vtbl_arylen: - result = &PL_vtbl_arylen; - break; - case want_vtbl_mglob: - result = &PL_vtbl_mglob; - break; - case want_vtbl_nkeys: - result = &PL_vtbl_nkeys; - break; - case want_vtbl_taint: - result = &PL_vtbl_taint; - break; - case want_vtbl_substr: - result = &PL_vtbl_substr; - break; - case want_vtbl_vec: - result = &PL_vtbl_vec; - break; - case want_vtbl_pos: - result = &PL_vtbl_pos; - break; - case want_vtbl_bm: - result = &PL_vtbl_bm; - break; - case want_vtbl_fm: - result = &PL_vtbl_fm; - break; - case want_vtbl_uvar: - result = &PL_vtbl_uvar; - break; - case want_vtbl_defelem: - result = &PL_vtbl_defelem; - break; - case want_vtbl_regexp: - result = &PL_vtbl_regexp; - break; - case want_vtbl_regdata: - result = &PL_vtbl_regdata; - break; - case want_vtbl_regdatum: - result = &PL_vtbl_regdatum; - break; -#ifdef USE_LOCALE_COLLATE - case want_vtbl_collxfrm: - result = &PL_vtbl_collxfrm; - break; -#endif - case want_vtbl_amagic: - result = &PL_vtbl_amagic; - break; - case want_vtbl_amagicelem: - result = &PL_vtbl_amagicelem; - break; - case want_vtbl_backref: - result = &PL_vtbl_backref; - break; - case want_vtbl_utf8: - result = &PL_vtbl_utf8; - break; - default: - result = NULL; - break; - } - return (MGVTBL*)result; + return (vtbl_id < 0 || vtbl_id >= magic_vtable_max) + ? NULL : PL_magic_vtables + vtbl_id; } I32 @@ -3890,13 +3716,15 @@ void Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) { if (ckWARN(WARN_IO)) { - const char * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL; + HEK * const name + = gv && (isGV_with_GP(gv)) + ? GvENAME_HEK((gv)) + : NULL; const char * const direction = have == '>' ? "out" : "in"; - if (name && *name) + if (name && HEK_LEN(name)) Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %s opened only for %sput", + "Filehandle %"HEKf" opened only for %sput", name, direction); else Perl_warner(aTHX_ packWARN(WARN_IO), @@ -3922,8 +3750,9 @@ Perl_report_evil_fh(pTHX_ const GV *gv) } if (ckWARN(warn_type)) { - const char * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL; + SV * const name + = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? + sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; const char * const pars = (const char *)(OP_IS_FILETEST(op) ? "" : "()"); const char * const func = @@ -3935,26 +3764,18 @@ Perl_report_evil_fh(pTHX_ const GV *gv) (const char *) (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"); - if (name && *name) { - Perl_warner(aTHX_ packWARN(warn_type), - "%s%s on %s %s %s", func, pars, vile, type, name); - 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?)\n", - func, pars, name - ); - } - else { - Perl_warner(aTHX_ packWARN(warn_type), - "%s%s on %s %s", func, pars, vile, type); - if (io && IoDIRP(io) && !(IoFLAGS(io) & IOf_FAKE_DIRP)) + const bool have_name = name && SvCUR(name); + Perl_warner(aTHX_ packWARN(warn_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?)\n", - func, pars + "\t(Are you trying to call %s%s on dirhandle%s%"SVf"?)\n", + func, pars, have_name ? " " : "", + SVfARG(have_name ? name : &PL_sv_no) ); - } } } @@ -4570,6 +4391,11 @@ dotted_decimal_version: } } + /* and we never support negative versions */ + if ( *d == '-') { + BADVERSION(s,errstr,"Invalid version format (negative version number)"); + } + /* consume all of the integer part */ while (isDIGIT(*d)) d++; @@ -4880,7 +4706,8 @@ 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 */ + if ( sv_isobject(ver) && sv_derived_from(ver, "version") ) + /* can just copy directly */ { I32 key; AV * const av = newAV(); @@ -4972,18 +4799,32 @@ Perl_upg_version(pTHX_ SV *ver, bool qv) if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) ) { + STRLEN len; + /* may get too much accuracy */ char tbuf[64]; + SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0; + char *buf; #ifdef USE_LOCALE_NUMERIC - char *loc = setlocale(LC_NUMERIC, "C"); + char *loc = savepv(setlocale(LC_NUMERIC, NULL)); + setlocale(LC_NUMERIC, "C"); #endif - STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); + if (sv) { + Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver)); + buf = SvPV(sv, len); + } + else { + len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver)); + buf = tbuf; + } #ifdef USE_LOCALE_NUMERIC setlocale(LC_NUMERIC, loc); + Safefree(loc); #endif - while (tbuf[len-1] == '0' && len > 0) len--; - if ( tbuf[len-1] == '.' ) len--; /* eat the trailing decimal */ - version = savepvn(tbuf, len); + while (buf[len-1] == '0' && len > 0) len--; + if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */ + version = savepvn(buf, len); + SvREFCNT_dec(sv); } #ifdef SvVOK else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */ @@ -5613,7 +5454,7 @@ Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { } #else /* In any case have a stub so that there's code corresponding - * to the my_socketpair in global.sym. */ + * to the my_socketpair in embed.fnc. */ int Perl_my_socketpair (int family, int type, int protocol, int fd[2]) { #ifdef HAS_SOCKETPAIR @@ -5730,6 +5571,10 @@ Perl_parse_unicode_opts(pTHX_ const char **popt) return opt; } +#ifdef VMS +# include +#endif + U32 Perl_seed(pTHX) { @@ -5761,7 +5606,6 @@ Perl_seed(pTHX) #endif U32 u; #ifdef VMS -# include /* when[] = (low 32 bits, high 32 bits) of time since epoch * in 100-ns units, typically incremented ever 10 ms. */ unsigned int when[2]; @@ -5851,25 +5695,6 @@ Perl_get_hash_seed(pTHX) return myseed; } -#ifdef USE_ITHREADS -bool -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; - if (stashpv && name) - if (strEQ(stashpv, name)) - return TRUE; - return FALSE; -} -#endif - - #ifdef PERL_GLOBAL_STRUCT #define PERL_GLOBAL_STRUCT_INIT @@ -5894,18 +5719,15 @@ Perl_init_global_struct(pTHX) # undef PERLVARA # undef PERLVARI # undef PERLVARIC -# undef PERLVARISC -# define PERLVAR(var,type) /**/ -# define PERLVARA(var,n,type) /**/ -# define PERLVARI(var,type,init) plvarsp->var = init; -# define PERLVARIC(var,type,init) plvarsp->var = init; -# define PERLVARISC(var,init) Copy(init, plvarsp->var, sizeof(init), char); +# define PERLVAR(prefix,var,type) /**/ +# define PERLVARA(prefix,var,n,type) /**/ +# define PERLVARI(prefix,var,type,init) plvarsp->prefix##var = init; +# define PERLVARIC(prefix,var,type,init) plvarsp->prefix##var = init; # include "perlvars.h" # undef PERLVAR # undef PERLVARA # undef PERLVARI # undef PERLVARIC -# undef PERLVARISC # ifdef PERL_GLOBAL_STRUCT plvarsp->Gppaddr = (Perl_ppaddr_t*) @@ -6444,7 +6266,7 @@ Perl_xs_version_bootcheck(pTHX_ U32 items, U32 ax, const char *xs_p, } if (sv) { SV *xssv = Perl_newSVpvn_flags(aTHX_ xs_p, xs_len, SVs_TEMP); - SV *pmsv = sv_derived_from(sv, "version") + SV *pmsv = sv_isobject(sv) && sv_derived_from(sv, "version") ? sv : sv_2mortal(new_version(sv)); xssv = upg_version(xssv, 0); if ( vcmp(pmsv,xssv) ) { @@ -6538,6 +6360,19 @@ long _ftol( double ); /* Defined by VC6 C libs. */ long _ftol2( double dblSource ) { return _ftol( dblSource ); } #endif +PERL_STATIC_INLINE bool +S_gv_has_usable_name(pTHX_ GV *gv) +{ + GV **gvp; + return GvSTASH(gv) + && HvENAME(GvSTASH(gv)) + && (gvp = (GV **)hv_fetch( + GvSTASH(gv), GvNAME(gv), + GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0 + )) + && *gvp == gv; +} + void Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { @@ -6545,7 +6380,8 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) SV * const dbsv = GvSVn(PL_DBsub); const bool save_taint = PL_tainted; - /* We do not care about using sv to call CV; + /* When we are called from pp_goto (svp is null), + * we do not care about using dbsv to call CV; * it's for informational purposes only. */ @@ -6556,23 +6392,33 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); - if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) + if (!svp) { + gv_efullname3(dbsv, gv, NULL); + } + else if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED)) || strEQ(GvNAME(gv), "END") - || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */ + || ( /* Could be imported, and old sub redefined. */ + (GvCV(gv) != cv || !S_gv_has_usable_name(aTHX_ gv)) + && !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((const GV *)*svp) == cv) - && (gv = (GV *)*svp) + /* Use GV from the stack as a fallback. */ + && S_gv_has_usable_name(aTHX_ gv = (GV *)*svp) ) ) - )) { - /* Use GV from the stack as a fallback. */ + ) { /* GV is potentially non-unique, or contain different CV. */ SV * const tmp = newRV(MUTABLE_SV(cv)); sv_setsv(dbsv, tmp); SvREFCNT_dec(tmp); } else { - gv_efullname3(dbsv, gv, NULL); + sv_sethek(dbsv, HvENAME_HEK(GvSTASH(gv))); + sv_catpvs(dbsv, "::"); + sv_catpvn_flags( + dbsv, GvNAME(gv), GvNAMELEN(gv), + GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES + ); } } else { @@ -6597,7 +6443,7 @@ Perl_my_dirfd(pTHX_ DIR * dir) { return dir->dd_fd; #else Perl_die(aTHX_ PL_no_func, "dirfd"); - /* NOT REACHED */ + assert(0); /* NOT REACHED */ return 0; #endif } @@ -6621,8 +6467,8 @@ Perl_get_re_arg(pTHX_ SV *sv) { * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */