X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=3635d352f2e488fb7147cc75a83abcd81541ffa1;hb=cf2649810f00335bd657355d81bcc9384a620135;hp=ae831e4f8a0374df857df81452e82501827c0a7b;hpb=e62f0680cdecd36f79df8a7dabc61c6a2739f07a;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index ae831e4..3635d35 100644 --- a/util.c +++ b/util.c @@ -152,7 +152,6 @@ Perl_safesysfree(Malloc_t where) #endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { - /*SUPPRESS 701*/ PerlMem_free(where); } } @@ -367,14 +366,13 @@ void Perl_fbm_compile(pTHX_ SV *sv, U32 flags) { const register U8 *s; - register U8 *table; register U32 i; STRLEN len; I32 rarest = 0; U32 frequency = 256; if (flags & FBMcf_TAIL) { - MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; + MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ if (mg && mg->mg_len >= 0) mg->mg_len++; @@ -386,6 +384,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) if (len > 2) { const unsigned char *sb; const U8 mlen = (len>255) ? 255 : (U8)len; + register U8 *table; Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET); table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET); @@ -584,7 +583,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 tmp; top2: - /*SUPPRESS 560*/ if ((tmp = table[*s])) { if ((s += tmp) < bigend) goto top2; @@ -634,13 +632,13 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit char * Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last) { - register unsigned char *big; + const register unsigned char *big; register I32 pos; register I32 previous; register I32 first; - register unsigned char *little; + const register unsigned char *little; register I32 stop_pos; - register unsigned char *littleend; + const register unsigned char *littleend; I32 found = 0; if (*old_posp == -1 @@ -649,7 +647,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift cant_find: if ( BmRARE(littlestr) == '\n' && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) { - little = (unsigned char *)(SvPVX(littlestr)); + little = (const unsigned char *)(SvPVX_const(littlestr)); littleend = little + SvCUR(littlestr); first = *little++; goto check_tail; @@ -657,12 +655,12 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift return Nullch; } - little = (unsigned char *)(SvPVX(littlestr)); + 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 = (unsigned char *)(SvPVX(bigstr)); + 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) { @@ -682,7 +680,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift } big -= previous; do { - register unsigned char *s, *x; + const register unsigned char *s, *x; if (pos >= stop_pos) break; if (big[pos] != first) continue; @@ -704,7 +702,7 @@ Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift if (!SvTAIL(littlestr) || (end_shift > 0)) return Nullch; /* Ignore the trailing "\n". This code is not microoptimized */ - big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr)); + big = (const unsigned char *)(SvPVX_const(bigstr) + SvCUR(bigstr)); stop_pos = littleend - little; /* Actual littlestr len */ if (stop_pos == 0) return (char*)big; @@ -766,8 +764,8 @@ Perl_savepv(pTHX_ const char *pv) else { char *newaddr; const STRLEN pvlen = strlen(pv)+1; - New(902,newaddr,pvlen,char); - return strcpy(newaddr,pv); + Newx(newaddr,pvlen,char); + return memcpy(newaddr,pv,pvlen); } } @@ -790,7 +788,7 @@ Perl_savepvn(pTHX_ const char *pv, register I32 len) { register char *newaddr; - New(903,newaddr,len+1,char); + Newx(newaddr,len+1,char); /* Give a meaning to NULL pointer mainly for the use in sv_magic() */ if (pv) { /* might not be null terminated */ @@ -814,16 +812,18 @@ char * Perl_savesharedpv(pTHX_ const char *pv) { register char *newaddr; + STRLEN pvlen; if (!pv) return Nullch; - newaddr = (char*)PerlMemShared_malloc(strlen(pv)+1); + pvlen = strlen(pv)+1; + newaddr = (char*)PerlMemShared_malloc(pvlen); if (!newaddr) { PerlLIO_write(PerlIO_fileno(Perl_error_log), PL_no_mem, strlen(PL_no_mem)); my_exit(1); } - return strcpy(newaddr,pv); + return memcpy(newaddr,pv,pvlen); } /* @@ -843,7 +843,7 @@ Perl_savesvpv(pTHX_ SV *sv) register char *newaddr; ++len; - New(903,newaddr,len,char); + Newx(newaddr,len,char); return (char *) CopyD(pv,newaddr,len,char); } @@ -863,8 +863,8 @@ S_mess_alloc(pTHX) return PL_mess_sv; /* Create as PVMG now, to avoid any upgrading later */ - New(905, sv, 1, SV); - Newz(905, any, 1, XPVMG); + Newx(sv, 1, SV); + Newxz(any, 1, XPVMG); SvFLAGS(sv) = SVt_PVMG; SvANY(sv) = (void*)any; SvPV_set(sv, 0); @@ -952,7 +952,7 @@ Perl_mess(pTHX_ const char *pat, ...) } STATIC COP* -S_closest_cop(pTHX_ COP *cop, OP *o) +S_closest_cop(pTHX_ COP *cop, const OP *o) { /* Look for PL_op starting from o. cop is the last COP we've seen. */ @@ -979,7 +979,7 @@ S_closest_cop(pTHX_ COP *cop, OP *o) /* Nothing found. */ - return 0; + return Null(COP *); } SV * @@ -1053,9 +1053,9 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) else { #ifdef USE_SFIO /* SFIO can really mess with your errno */ - int e = errno; + const int e = errno; #endif - PerlIO *serr = Perl_error_log; + PerlIO * const serr = Perl_error_log; PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); @@ -1074,7 +1074,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) GV *gv; CV *cv; /* sv_2cv might call Perl_croak() */ - SV *olddiehook = PL_diehook; + SV * const olddiehook = PL_diehook; assert(PL_diehook); ENTER; @@ -1108,22 +1108,22 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8) } } -STATIC char * +STATIC const char * S_vdie_croak_common(pTHX_ const char* pat, va_list* args, STRLEN* msglen, I32* utf8) { dVAR; - char *message; + const char *message; if (pat) { - SV *msv = vmess(pat, args); + SV * const msv = vmess(pat, args); if (PL_errors && SvCUR(PL_errors)) { sv_catsv(PL_errors, msv); - message = SvPV(PL_errors, *msglen); + message = SvPV_const(PL_errors, *msglen); SvCUR_set(PL_errors, 0); } else - message = SvPV(msv,*msglen); + message = SvPV_const(msv,*msglen); *utf8 = SvUTF8(msv); } else { @@ -1151,7 +1151,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) "%p: die: curstack = %p, mainstack = %p\n", thr, PL_curstack, PL_mainstack)); - message = S_vdie_croak_common(aTHX_ pat, args, &msglen, &utf8); + message = vdie_croak_common(pat, args, &msglen, &utf8); PL_restartop = die_where(message, msglen); SvFLAGS(ERRSV) |= utf8; @@ -1203,7 +1203,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) JMPENV_JUMP(3); } else if (!message) - message = SvPVx(ERRSV, msglen); + message = SvPVx_const(ERRSV, msglen); write_to_stderr(message, msglen); my_failure_exit(); @@ -1256,21 +1256,18 @@ void Perl_vwarn(pTHX_ const char* pat, va_list *args) { dVAR; - char *message; - HV *stash; - GV *gv; - CV *cv; - SV *msv; STRLEN msglen; - I32 utf8 = 0; - - msv = vmess(pat, args); - utf8 = SvUTF8(msv); - message = SvPV(msv, msglen); + SV * const msv = vmess(pat, args); + const I32 utf8 = SvUTF8(msv); + const char * const message = SvPV_const(msv, msglen); if (PL_warnhook) { /* sv_2cv might call Perl_warn() */ - SV *oldwarnhook = PL_warnhook; + SV * const oldwarnhook = PL_warnhook; + CV * cv; + HV * stash; + GV * gv; + ENTER; SAVESPTR(PL_warnhook); PL_warnhook = Nullsv; @@ -1281,6 +1278,8 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + SAVESPTR(PL_warnhook); + PL_warnhook = Nullsv; save_re_context(); msg = newSVpvn(message, msglen); SvFLAGS(msg) |= utf8; @@ -1359,7 +1358,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) if (ckDEAD(err)) { SV * const msv = vmess(pat, args); STRLEN msglen; - const char *message = SvPV(msv, msglen); + const char *message = SvPV_const(msv, msglen); const I32 utf8 = SvUTF8(msv); if (PL_diehook) { @@ -1379,6 +1378,58 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } } +/* implements the ckWARN? macros */ + +bool +Perl_ckwarn(pTHX_ U32 w) +{ + return + ( + isLEXWARN_on + && PL_curcop->cop_warnings != pWARN_NONE + && ( + PL_curcop->cop_warnings == pWARN_ALL + || isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) + || (unpackWARN2(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) + || (unpackWARN3(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) + || (unpackWARN4(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) + ) + ) + || + ( + isLEXWARN_off && PL_dowarn & G_WARN_ON + ) + ; +} + +/* implements the ckWARN?_d macro */ + +bool +Perl_ckwarn_d(pTHX_ U32 w) +{ + return + isLEXWARN_off + || PL_curcop->cop_warnings == pWARN_ALL + || ( + PL_curcop->cop_warnings != pWARN_NONE + && ( + isWARN_on(PL_curcop->cop_warnings, unpackWARN1(w)) + || (unpackWARN2(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN2(w))) + || (unpackWARN3(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN3(w))) + || (unpackWARN4(w) && + isWARN_on(PL_curcop->cop_warnings, unpackWARN4(w))) + ) + ) + ; +} + + + /* since we've already done strlen() for both nam and val * we can use that info to make things faster than * sprintf(s, "%s=%s", nam, val) @@ -1412,7 +1463,6 @@ Perl_my_setenv(pTHX_ const char *nam, const char *val) I32 max; char **tmpenv; - /*SUPPRESS 530*/ for (max = i; environ[max]; max++) ; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j= sizeof(tmpbuf)) break; + /* FIXME? Convert to memcpy */ cur = strcpy(tmpbuf, scriptname); } } while (extidx >= 0 && ext[extidx] /* try an extension? */ @@ -2900,15 +2951,17 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc tmpbuf[len++] = ':'; #else if (len -#if defined(atarist) || defined(__MINT__) || defined(DOSISH) +# if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' -#endif +# endif ) tmpbuf[len++] = '/'; if (len == 2 && tmpbuf[0] == '.') seen_dot = 1; #endif + /* FIXME? Convert to memcpy by storing previous strlen(scriptname) + */ (void)strcpy(tmpbuf + len, scriptname); #endif /* !VMS */ @@ -2960,8 +3013,7 @@ Perl_find_script(pTHX_ const char *scriptname, bool dosearch, const char **searc } scriptname = Nullch; } - if (xfailed) - Safefree(xfailed); + Safefree(xfailed); scriptname = xfound; } return (scriptname ? savepv(scriptname) : Nullch); @@ -2994,7 +3046,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { - dVAR; + dVAR; #if defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); @@ -3003,7 +3055,7 @@ Perl_set_context(void *t) Perl_croak_nocontext("panic: pthread_setspecific"); # endif #else - (void)t; + PERL_UNUSED_ARG(t); #endif } @@ -3052,7 +3104,7 @@ Perl_get_ppaddr(pTHX) char * Perl_getenv_len(pTHX_ const char *env_elem, unsigned long *len) { - char *env_trans = PerlEnv_getenv(env_elem); + char * const env_trans = PerlEnv_getenv(env_elem); if (env_trans) *len = strlen(env_trans); return env_trans; @@ -3215,23 +3267,19 @@ Perl_my_fflush_all(pTHX) void Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op) { - const char *func = + const char * const func = op == OP_READLINE ? "readline" : /* "" not nice */ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */ PL_op_desc[op]; - const char *pars = OP_IS_FILETEST(op) ? "" : "()"; - const char *type = OP_IS_SOCKET(op) + const char * const pars = OP_IS_FILETEST(op) ? "" : "()"; + const char * const type = OP_IS_SOCKET(op) || (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"; - const char *name = NULL; - - if (gv && isGV(gv)) { - name = GvENAME(gv); - } + const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL; if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) { if (ckWARN(WARN_IO)) { - const char *direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; + const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out"; if (name && *name) Perl_warner(aTHX_ packWARN(WARN_IO), "Filehandle %s opened only for %sput", @@ -3346,11 +3394,13 @@ Perl_init_tm(pTHX_ struct tm *ptm) /* see mktime, strftime and asctime */ { #ifdef HAS_TM_TM_ZONE Time_t now; - struct tm* my_tm; + const struct tm* my_tm; (void)time(&now); my_tm = localtime(&now); if (my_tm) Copy(my_tm, ptm, 1, struct tm); +#else + PERL_UNUSED_ARG(ptm); #endif } @@ -3586,7 +3636,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in } STMT_END; #endif buflen = 64; - New(0, buf, buflen, char); + Newx(buf, buflen, char); len = strftime(buf, buflen, fmt, &mytm); /* ** The following is needed to handle to the situation where @@ -3609,7 +3659,7 @@ Perl_my_strftime(pTHX_ const char *fmt, int sec, int min, int hour, int mday, in const int fmtlen = strlen(fmt); const int bufsize = fmtlen + buflen; - New(0, buf, bufsize, char); + Newx(buf, bufsize, char); while (buf) { buflen = strftime(buf, bufsize, fmt, &mytm); if (buflen > 0 && buflen < bufsize) @@ -3825,18 +3875,30 @@ it doesn't. =cut */ -char * +const char * Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) { const char *start = s; - const char *pos = s; - I32 saw_period = 0; - bool saw_under = 0; - SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ - (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ - AvREAL_on((AV*)sv); - - /* pre-scan the imput string to check for decimals */ + const char *pos; + const char *last; + int saw_period = 0; + int saw_under = 0; + int width = 3; + AV *av = newAV(); + SV* 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 + + if (*s == 'v') { + s++; /* get past 'v' */ + qv = 1; /* force quoted version processing */ + } + + last = pos = s; + + /* pre-scan the input string to check for decimals/underbars */ while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) { if ( *pos == '.' ) @@ -3844,38 +3906,45 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( saw_under ) Perl_croak(aTHX_ "Invalid version format (underscores before decimal)"); saw_period++ ; + last = pos; } else if ( *pos == '_' ) { if ( saw_under ) Perl_croak(aTHX_ "Invalid version format (multiple underscores)"); saw_under = 1; + width = pos - last - 1; /* natural width of sub-version */ } pos++; } - pos = s; - if (*pos == 'v') { - pos++; /* get past 'v' */ + if ( saw_period > 1 ) { qv = 1; /* force quoted version processing */ } + + pos = s; + + if ( qv ) + hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + if ( saw_under ) { + hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + } + if ( !qv && width < 3 ) + hv_store((HV *)hv, "width", 5, newSViv(width), 0); + while (isDIGIT(*pos)) pos++; if (!isALPHA(*pos)) { I32 rev; - if (*s == 'v') s++; /* get past 'v' */ - for (;;) { rev = 0; { /* this is atoi() that delimits on underscores */ - const char *end = pos; + const char *end = pos; I32 mult = 1; I32 orev; - if ( s < pos && s > start && *(s-1) == '_' ) { - mult *= -1; /* alpha version */ - } + /* the following if() will only be true after the decimal * point of a version originally created with a bare * floating point number, i.e. not quoted in any way @@ -3889,6 +3958,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( PERL_ABS(orev) > PERL_ABS(rev) ) Perl_croak(aTHX_ "Integer overflow in version"); s++; + if ( *s == '_' ) + s++; } } else { @@ -3901,10 +3972,12 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } } } - + /* Append revision */ - av_push((AV *)sv, newSViv(rev)); - if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1])) + av_push(av, newSViv(rev)); + if ( *pos == '.' && isDIGIT(pos[1]) ) + s = ++pos; + else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; else if ( isDIGIT(*pos) ) s = pos; @@ -3912,15 +3985,22 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) s = pos; break; } - while ( isDIGIT(*pos) ) { - if ( saw_period == 1 && pos-s == 3 ) - break; - pos++; + if ( qv ) { + while ( isDIGIT(*pos) ) + pos++; + } + else { + int digits = 0; + while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) { + if ( *pos != '_' ) + digits++; + pos++; + } } } } - if ( qv ) { /* quoted versions always become full version objects */ - I32 len = av_len((AV *)sv); + if ( qv ) { /* quoted versions always get at least three terms*/ + I32 len = av_len(av); /* This for loop appears to trigger a compiler bug on OS X, as it loops infinitely. Yes, len is negative. No, it makes no sense. Compiler in question is: @@ -3930,9 +4010,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) */ len = 2 - len; while (len-- > 0) - av_push((AV *)sv, newSViv(0)); + av_push(av, newSViv(0)); } - return (char *)s; + + if ( av_len(av) == -1 ) /* oops, someone forgot to pass a value */ + av_push(av, newSViv(0)); + + /* And finally, store the AV in the hash */ + hv_store((HV *)hv, "version", 7, (SV *)av, 0); + return s; } /* @@ -3955,23 +4041,49 @@ Perl_new_version(pTHX_ SV *ver) if ( sv_derived_from(ver,"version") ) /* can just copy directly */ { I32 key; - AV *av = (AV *)SvRV(ver); - SV* sv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ - (void)sv_upgrade(sv, SVt_PVAV); /* needs to be an AV type */ - AvREAL_on((AV*)sv); - for ( key = 0; key <= av_len(av); key++ ) + AV * const av = newAV(); + AV *sav; + /* 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((HV *)ver, "alpha", 5) ) + hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + + if ( hv_exists((HV*)ver, "width", 5 ) ) { - const I32 rev = SvIV(*av_fetch(av, key, FALSE)); - av_push((AV *)sv, newSViv(rev)); + const I32 width = SvIV(*hv_fetch((HV*)ver, "width", 5, FALSE)); + hv_store((HV *)hv, "width", 5, newSViv(width), 0); } + + sav = (AV *)*hv_fetch((HV*)ver, "version", 7, FALSE); + /* This will get reblessed later if a derived class*/ + for ( key = 0; key <= av_len(sav); key++ ) + { + const I32 rev = SvIV(*av_fetch(sav, key, FALSE)); + av_push(av, newSViv(rev)); + } + + hv_store((HV *)hv, "version", 7, (SV *)av, 0); return rv; } #ifdef SvVOK if ( SvVOK(ver) ) { /* already a v-string */ char *version; MAGIC* mg = mg_find(ver,PERL_MAGIC_vstring); - version = savepvn( (const char*)mg->mg_ptr,mg->mg_len ); - sv_setpv(rv,version); + const STRLEN len = mg->mg_len; + version = savepvn( (const char*)mg->mg_ptr, len); + sv_setpvn(rv,version,len); Safefree(version); } else { @@ -4017,7 +4129,7 @@ Perl_upg_version(pTHX_ SV *ver) #endif else /* must be a string or something like a string */ { - version = savesvpv(ver); + version = savepv(SvPV_nolen(ver)); } (void)scan_version(version, ver, qv); Safefree(version); @@ -4043,35 +4155,60 @@ SV * Perl_vnumify(pTHX_ SV *vs) { I32 i, len, digit; - SV *sv = newSV(0); + int width; + bool alpha = FALSE; + SV * const sv = newSV(0); + AV *av; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); + + /* see if various flags exist */ + if ( hv_exists((HV*)vs, "alpha", 5 ) ) + alpha = TRUE; + if ( hv_exists((HV*)vs, "width", 5 ) ) + width = SvIV(*hv_fetch((HV*)vs, "width", 5, FALSE)); + else + width = 3; + + + /* attempt to retrieve the version array */ + if ( !(av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE) ) ) { + sv_catpvn(sv,"0",1); + return sv; + } + + len = av_len(av); if ( len == -1 ) { sv_catpvn(sv,"0",1); return sv; } - digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); + + digit = SvIV(*av_fetch(av, 0, 0)); Perl_sv_setpvf(aTHX_ sv,"%d.", (int)PERL_ABS(digit)); for ( i = 1 ; i < len ; i++ ) { - digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); + digit = SvIV(*av_fetch(av, i, 0)); + if ( width < 3 ) { + const int denom = (int)pow(10,(3-width)); + const div_t term = div((int)PERL_ABS(digit),denom); + Perl_sv_catpvf(aTHX_ sv,"%0*d_%d", width, term.quot, term.rem); + } + else { + Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); + } } if ( len > 0 ) { - digit = SvIVX(*av_fetch((AV *)vs, len, 0)); - if ( (int)PERL_ABS(digit) != 0 || len == 1 ) - { - if ( digit < 0 ) /* alpha version */ - sv_catpvn(sv,"_",1); - /* Don't display additional trailing zeros */ - Perl_sv_catpvf(aTHX_ sv,"%03d", (int)PERL_ABS(digit)); - } + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha && width == 3 ) /* alpha version */ + Perl_sv_catpv(aTHX_ sv,"_"); + /* Don't display additional trailing zeros */ + if ( digit > 0 ) + Perl_sv_catpvf(aTHX_ sv,"%0*d", width, (int)digit); } - else /* len == 0 */ + else /* len == 1 */ { sv_catpvn(sv,"000",3); } @@ -4096,33 +4233,44 @@ SV * Perl_vnormal(pTHX_ SV *vs) { I32 i, len, digit; + bool alpha = FALSE; SV *sv = newSV(0); + AV *av; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); - if ( len == -1 ) - { + + if ( hv_exists((HV*)vs, "alpha", 5 ) ) + alpha = TRUE; + av = (AV *)*hv_fetch((HV*)vs, "version", 7, FALSE); + + len = av_len(av); + if ( len == -1 ) { sv_catpvn(sv,"",0); return sv; } - digit = SvIVX(*av_fetch((AV *)vs, 0, 0)); - Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit); - for ( i = 1 ; i <= len ; i++ ) - { - digit = SvIVX(*av_fetch((AV *)vs, i, 0)); - if ( digit < 0 ) - Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit); + digit = SvIV(*av_fetch(av, 0, 0)); + Perl_sv_setpvf(aTHX_ sv,"v%"IVdf,(IV)digit); + for ( i = 1 ; i <= len-1 ; i++ ) { + digit = SvIV(*av_fetch(av, i, 0)); + Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); + } + + if ( len > 0 ) { + /* handle last digit specially */ + digit = SvIV(*av_fetch(av, len, 0)); + if ( alpha ) + Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit); else - Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit); + Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit); } - + if ( len <= 2 ) { /* short version, must be at least three */ for ( len = 2 - len; len != 0; len-- ) sv_catpvn(sv,".0",2); } return sv; -} +} /* =for apidoc vstringify @@ -4138,16 +4286,17 @@ the original version contained 1 or more dots, respectively SV * Perl_vstringify(pTHX_ SV *vs) { - I32 len, digit; + I32 qv = 0; if ( SvROK(vs) ) vs = SvRV(vs); - len = av_len((AV *)vs); - digit = SvIVX(*av_fetch((AV *)vs, len, 0)); - if ( len < 2 || ( len == 2 && digit < 0 ) ) - return vnumify(vs); - else + if ( hv_exists((HV *)vs, "qv", 2) ) + qv = 1; + + if ( qv ) return vnormal(vs); + else + return vnumify(vs); } /* @@ -4160,40 +4309,65 @@ converted into version objects. */ int -Perl_vcmp(pTHX_ SV *lsv, SV *rsv) +Perl_vcmp(pTHX_ SV *lhv, SV *rhv) { I32 i,l,m,r,retval; - if ( SvROK(lsv) ) - lsv = SvRV(lsv); - if ( SvROK(rsv) ) - rsv = SvRV(rsv); - l = av_len((AV *)lsv); - r = av_len((AV *)rsv); + bool lalpha = FALSE; + bool ralpha = FALSE; + I32 left = 0; + I32 right = 0; + AV *lav, *rav; + if ( SvROK(lhv) ) + lhv = SvRV(lhv); + if ( SvROK(rhv) ) + rhv = SvRV(rhv); + + /* get the left hand term */ + lav = (AV *)*hv_fetch((HV*)lhv, "version", 7, FALSE); + if ( hv_exists((HV*)lhv, "alpha", 5 ) ) + lalpha = TRUE; + + /* and the right hand term */ + rav = (AV *)*hv_fetch((HV*)rhv, "version", 7, FALSE); + if ( hv_exists((HV*)rhv, "alpha", 5 ) ) + ralpha = TRUE; + + l = av_len(lav); + r = av_len(rav); m = l < r ? l : r; retval = 0; i = 0; while ( i <= m && retval == 0 ) { - I32 left = SvIV(*av_fetch((AV *)lsv,i,0)); - I32 right = SvIV(*av_fetch((AV *)rsv,i,0)); - bool lalpha = left < 0 ? 1 : 0; - bool ralpha = right < 0 ? 1 : 0; - left = abs(left); - right = abs(right); - if ( left < right || (left == right && lalpha && !ralpha) ) + left = SvIV(*av_fetch(lav,i,0)); + right = SvIV(*av_fetch(rav,i,0)); + if ( left < right ) retval = -1; - if ( left > right || (left == right && ralpha && !lalpha) ) + if ( left > right ) retval = +1; i++; } + /* tiebreaker for alpha with identical terms */ + if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) ) + { + if ( lalpha && !ralpha ) + { + retval = -1; + } + else if ( ralpha && !lalpha) + { + retval = +1; + } + } + if ( l != r && retval == 0 ) /* possible match except for trailing 0's */ { if ( l < r ) { while ( i <= r && retval == 0 ) { - if ( SvIV(*av_fetch((AV *)rsv,i,0)) != 0 ) + if ( SvIV(*av_fetch(rav,i,0)) != 0 ) retval = -1; /* not a match after all */ i++; } @@ -4202,7 +4376,7 @@ Perl_vcmp(pTHX_ SV *lsv, SV *rsv) { while ( i <= l && retval == 0 ) { - if ( SvIV(*av_fetch((AV *)lsv,i,0)) != 0 ) + if ( SvIV(*av_fetch(lav,i,0)) != 0 ) retval = +1; /* not a match after all */ i++; } @@ -4487,7 +4661,7 @@ some level of strict-ness. void Perl_sv_nosharing(pTHX_ SV *sv) { - (void)sv; + PERL_UNUSED_ARG(sv); } /* @@ -4503,7 +4677,7 @@ some level of strict-ness. void Perl_sv_nolocking(pTHX_ SV *sv) { - (void)sv; + PERL_UNUSED_ARG(sv); } @@ -4520,7 +4694,7 @@ some level of strict-ness. void Perl_sv_nounlocking(pTHX_ SV *sv) { - (void)sv; + PERL_UNUSED_ARG(sv); } U32 @@ -4695,6 +4869,23 @@ 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); + + if (stashpv == name) + return TRUE; + if (stashpv && name) + if (strEQ(stashpv, name)) + return TRUE; + return FALSE; +} +#endif + + #ifdef PERL_GLOBAL_STRUCT struct perl_vars * @@ -4769,6 +4960,55 @@ Perl_free_global_struct(pTHX_ struct perl_vars *plvarsp) #endif /* PERL_GLOBAL_STRUCT */ +#ifdef PERL_MEM_LOG + +#define PERL_MEM_LOG_SPRINTF_BUF_SIZE 128 + +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 + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + sprintf(buf, + "alloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf"\n", + filename, linenumber, funcname, + n, typesize, typename, n * typesize, PTR2UV(newalloc)); + PerlLIO_write(2, buf, strlen(buf)); +#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) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + sprintf(buf, + "realloc: %s:%d:%s: %"IVdf" %"UVuf" %s = %"IVdf": %"UVxf" -> %"UVxf"\n", + filename, linenumber, funcname, + n, typesize, typename, n * typesize, PTR2UV(oldalloc), PTR2UV(newalloc)); + PerlLIO_write(2, buf, strlen(buf)); +#endif + return newalloc; +} + +Malloc_t +Perl_mem_log_free(Malloc_t oldalloc, const char *filename, const int linenumber, const char *funcname) +{ +#ifdef PERL_MEM_LOG_STDERR + /* We can't use PerlIO for obvious reasons. */ + char buf[PERL_MEM_LOG_SPRINTF_BUF_SIZE]; + sprintf(buf, "free: %s:%d:%s: %"UVxf"\n", + filename, linenumber, funcname, PTR2UV(oldalloc)); + PerlLIO_write(2, buf, strlen(buf)); +#endif + return oldalloc; +} + +#endif /* PERL_MEM_LOG */ + /* * Local variables: * c-indentation-style: bsd